你可以查看:我得分的问题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
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
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货