'驱动器类型常量枚举
Public Enum apiDriveType
apiDriveTypeUnKnown = 0 'DRIVE_UNKNOWN = 0 '未知类型
apiDriveTypeNone = 1 'DRIVE_NO_ROOT_DIR = 1 '无效
apiDriveTypeRemoveble = 2 'DRIVE_REMOVABLE = 2 '软盘或移动磁盘
apiDriveTypeFixed = 3 'DRIVE_FIXED = 3 '硬盘
apiDriveTypeRemote = 4 'DRIVE_REMOTE = 4 '网络映射盘
apiDriveTypeCDROM = 5 'DRIVE_CDROM = 5 '光驱
apiDriveTypeRamDisk = 6 'DRIVE_RAMDISK = 6 'RAM盘
End Enum
'返回驱动器类型
Public Declare Function apiGetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As apiDriveType
'==========================================================================================
'-函数名称: GetLegalPath
'-功能描述: 从一个可能包含路径名的字符串中返回合法的路径名
'-输入参数: pathname 必需的，路径名
'-返回参数: 路径名合法时返回修正并标准化后的路径名，否则返回空字符串
'-使用示例: =GetLegalPath("c:\Windows") '返回"C:\Windows\"
'-相关调用: apiGetDriveType(),UCase(),Mid$(),InStrRev(),Len()
'-使用注意:
'-其它说明; 满足以下任意条件的均视为不合法路径名：
' 指定的驱动器无效或类型未知
' 反斜线符号"\"成对出现
' 含有文件名命名规则中不允许出现的特殊符号/*?""<>|
' 冒号":"在除盘符后边第2个字符之外的任何位置出现
' 路径名长度大于允许最大长度260个字符
'
' 修正并标准化内容：
' 盘符转换为大写字母
' 自动在路径名右边加上一个反斜线符号"\"，如果已经有了则不加
'
'-兼 容 性: Windows 2000以上系统,Access 97 以上版本
'-参考资料:
'-作 者: 红尘如烟
'-创建日期; 2009-6-24
'==========================================================================================
Public Function GetLegalPath(ByVal pathname As String) As String
Dim lngDriveType As apiDriveType
GetLegalPath = ""
pathname = UCase(Left(pathname, 1)) & Mid$(pathname, 2)
If (Not pathname Like "*\") And Len(pathname) > 0 Then pathname = pathname & "\"
lngDriveType = apiGetDriveType(Left(pathname, 3))
If lngDriveType <> apiDriveTypeNone And lngDriveType <> apiDriveTypeUnKnown Then
If (Not pathname Like "*\\*") And (pathname Like "*[!/*?""<>|]*") Then
If InStrRev(pathname, ":", , vbTextCompare) = 2 Then
If Len(pathname) <= 260 Then GetLegalPath = pathname
End If
End If
End If
End Function
'==========================================================================================
'-函数名称: CreateDir
'-功能描述: 创建目录，可创建不存在的多级目录（即创建每一级目录的文件夹），而不用单
' 独创建每一个文件夹，对于已经存在的文件夹则会被忽略
'-输入参数: pathname 必需的，目录路径名
'-返回参数:
'-使用示例: Call CreateDir("C:\a\b\c\d\e\f\g\")
'-相关调用: InStrRev(),Left(),MkDir()
'-使用注意: 调用此函数前必须先检查路径名的有效性(使用GetLegalPath函数)
'-兼 容 性: Windows 2000以上系统,Access 97 以上版本
'-参考资料:
'-作 者: 红尘如烟
'-创建日期; 2009-6-24
'==========================================================================================
Public Function CreateDir(pathname As String)
Dim strPath As String
Dim strFolders() As String
Dim intI As Integer
strPath = pathname
'取得目录级数
Do
strPath = Left(strPath, InStrRev(strPath, "\") - 1)
intI = intI + 1
Loop Until strPath Like "[A-z]:"
ReDim strFolders(1 To intI)
strPath = pathname
'将每一级目录的路径保存到数组
Do Until intI = 0
strPath = Left(strPath, InStrRev(strPath, "\") - 1)
strFolders(intI) = strPath & "\"
intI = intI - 1
Loop
'从根目录开始，循环每一级目录，如果不存在，则自动创建
For intI = LBound(strFolders) To UBound(strFolders)
If Not FolderExists(strFolders(intI)) Then Call MkDir(strFolders(intI))
Next
End Function
'==========================================================================================
'-函数名称: FileExists
'-功能描述: 判断一个文件是否已存在
'-输入参数: pathname 必需的，包含路径的文件名
'-返回参数: 文件存在时返回True,不存在或路径名无效时返回Flase
'-使用示例: If FileExists("C:\test.exe") Then
'-相关调用: Len(),GetAttr()
'-使用注意:
'-兼 容 性: Windows 2000以上系统,Access 97 以上版本
'-参考资料:
'-作 者: 红尘如烟
'-创建日期; 2009-6-24
'==========================================================================================
Public Function FileExists(ByVal pathname As String) As Boolean
On Error GoTo ErrorHandler
FileExists = False
If Len(pathname) > 0 Then
If (GetAttr(pathname) And vbDirectory) = 0 Then
FileExists = True
End If
End If
ExitFunction:
Exit Function
ErrorHandler:
FileExists = False
Resume ExitFunction
End Function
'==========================================================================================
'-函数名称: FolderExists
'-功能描述: 判断一个文件夹是否已存在
'-输入参数: pathname 必需的，包含路径的文件夹名称
'-返回参数: 文件夹存在时返回True,不存在或路径名无效时返回Flase
'-使用示例: If FolderExists("C:\abc\def\") Then
'-相关调用: Len(),GetAttr()
'-使用注意:
'-兼 容 性: Windows 2000以上系统,Access 97 以上版本
'-参考资料:
'-作 者: 红尘如烟
'-创建日期; 2009-6-24
'==========================================================================================
Public Function FolderExists(ByVal pathname As String) As Boolean
On Error GoTo ErrorHandler
FolderExists = False
If Len(pathname) > 0 Then
If (GetAttr(pathname) And vbDirectory) <> 0 Then
FolderExists = True
End If
End If
If Not pathname Like "[A-z]:\*" Then FolderExists = False
ExitFunction:
Exit Function
ErrorHandler:
FolderExists = False
Resume ExitFunction
End Function作者: ty_1029 时间: 2009-6-24 15:38
阁下研究的东西越来越深啊~~~~~~~~~~