你可以查看:我得分的问题Public Function CreateDir(ByVal strDirName As String, _
                          SucceedDir As String) As Boolean
'*****************************************************************
'函数功能:创建新的多级目录
'参数:strDirName:要创建的目录
'      SucceedDir: 成功创的目录
'成功则返回:True
'*****************************************************************
   Dim DirArrStr As Variant
   '逐段检测其有效性。
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim NewDirStr As String
   Dim NoValidChar As Variant
   Dim nDriveType As Long
   Dim GnDriveType As Integer
   
   On Error GoTo HELL
   '创建目录的无效字串(此处不包括":",因为有驱动器):
   NoValidChar = Array("*", ">", "<", "?", "|", Chr(34), "/")
   '字符转换为有效性字串:
        
        Dim bReplace As Boolean
        
        For j = 0 To 6
            If InStr(1, strDirName, NoValidChar(j), vbTextCompare) <> 0 Then
                If MsgBox("所给路径字串含非法字符,如要继续创建,这些字符将被删除。要继续创建吗?", _
                 vbCritical Or vbYesNo, "") = vbYes Then
                    bReplace = True
                    Exit For
                Else
                    CreateDir = False
                    Exit Function
                End If
            End If
        Next j
        
        '如果需要转换
        If bReplace = True Then
            For k = 0 To 6
                strDirName = Replace(strDirName, NoValidChar(k), "")
            Next k
        End If
   
   '先将目录分为字符段
   strDirName = Trim(strDirName)
   strDirName = IIf(Right(strDirName, 1) = "\", Left(strDirName, Len(strDirName) - 1), strDirName)
   DirArrStr = Split(strDirName, "\")
   
   NewDirStr = ""
   
   For i = 0 To UBound(DirArrStr)
       If i = 0 Then
            If Right(DirArrStr(i), 1) = ":" Then
                If DirExists(DirArrStr(i) & "\") Then
                    NewDirStr = DirArrStr(i) & "\"
                    nDriveType = GetDriveType(NewDirStr)
                    If GnDriveType <> DRIVE_FIXED Then
                        If GnDriveType = DRIVE_CDROM Then
                            MsgBox "无法在光驱上创建目录!", vbCritical Or vbOKOnly, "区域信息化管理系统"
                            CreateDir = False
                            Exit Function
                        ElseIf GnDriveType = DRIVE_REMOTE Then
                            If MsgBox("所给路径驱动非本地驱动器,如要继续创建,这将不利于系统的运行。要继续创建吗?", _
                                 vbCritical Or vbYesNo, "") = vbNo Then
                                 CreateDir = False
                                 Exit Function
                            End If
                        End If
                    End If
                Else
                    WriteErrLog Nothing, "CreateDir", 1068, "所给路径非法,无法创建!"
                End If
            Else
                WriteErrLog Nothing, "CreateDir", 1081, "所给路径非法,无法创建!"
                CreateDir = False
                Exit Function
            End If
       Else
            '有效字串长度不为0
            If Len(DirArrStr(i)) <> 0 Then
                '检测是否存在,不存在则创建
                If DirExists(NewDirStr & DirArrStr(i) & "\") = False Then
                    If InStr(1, DirArrStr(i), ":", vbTextCompare) <> 0 Then
                        If MsgBox("所给路径字串含非法字符,如要继续创建,这些字符将被删除。要继续创建吗?", _
                             vbCritical Or vbYesNo, "") = vbNo Then
                             CreateDir = False
                             Exit Function
                        End If
                    End If
                    MkDir NewDirStr & DirArrStr(i) & "\"
                
                End If
                NewDirStr = NewDirStr & DirArrStr(i) & "\"
            End If
       End If
   Next i
   SucceedDir = NewDirStr
   CreateDir = True
   Exit Function
   
HELL:
Err.Clear
CreateDir = False
  
End FunctionPublic Function DirExists(ByVal strDirName As String) As Boolean
'*****************************************************************
'函数功能:返回目录是否存在
'存在则返回:True
'*****************************************************************    Const strWILDCARD$ = "*.*"    Dim strDummy As String    On Error Resume Next    strDirName = IIf(Right(strDirName, 1) = "\", strDirName, strDirName & "\")
    strDummy = Dir$(strDirName & strWILDCARD, vbDirectory)
    DirExists = Not (strDummy = vbNullString)    Err = 0
End Function