[原创分享] 几个关于路径的有用函数

红尘如烟

'驱动器类型常量枚举
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

阁下研究的东西越来越深啊~~~~~~~~~~