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
 
 '判断是否非本机途径 \\jim97\bondale\1
 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