分类:
2008-10-13 16:33:12
Sub CreateDirectory(vDirectory As String)
'*******************************************************************************
'Sub: CreateDirectory
'Input: you want to build full path
'Subject: loop to build full path
'Prepared Date: 2005/9/06
'Last Modified Date: 2005/10/06
'*******************************************************************************
On Error GoTo Cmd_Err
Dim str1$, vpos%, vpostemp%, strComputerName$ 'vpos 是位置
vpos = 1
vpostemp = 1
'判断全文件是否存在
If (Dir(vDirectory, vbDirectory)) <> "" Then Exit Sub
'判断是否非本机途径
If Len(vDirectory) >= 3 And VBA.Left$(vDirectory, 2) = "\\" Then
vpos = InStr(3, vDirectory, "\", vbTextCompare)
strComputerName = Mid(vDirectory, 1, vpos - 1)
'从\下位开始
vpos = vpos + 1
End If
'loop建文件夹
While vpostemp > 0
vpostemp = InStr(vpos, vDirectory, "\", vbTextCompare)
If strcomputer <> "" Then
str1 = strComputerName & "\" & Mid$(vDirectory, 1, vpostemp) '非本机
Else
str1 = Mid$(vDirectory, 1, vpostemp)
End If
If (Dir(str1, vbDirectory)) = "" Then
MkDir (str1)
End If
vpos = vpostemp + 1
Wend
'建立全文件夹
If (Right(vDirectory, 1)) <> "\" Then MkDir vDirectory
Exit Sub
Cmd_Err:
MsgBox "创建错误: " & Err.Description
End Sub