pathctl.bas

这是用Vb编写的虚拟驱动程序,希望对大家有帮助.

Attribute VB_Name = "PathCTL"
'Modules For Working With Path Names
'Getting the short path name and the full (long) one
Declare Function OSGetShortPathName Lib "Kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Declare Function SHGetDesktopFolder Lib "shell32" (ByRef pshf As IVBShellFolder) As Long
Public Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Public Declare Function SHGetMalloc Lib "shell32" (ByRef pMalloc As IVBMalloc) As Long
Declare Function WritePrivateProfileString Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFilename As String) As Long

Public Function LongPath(Path As String) As String
    Dim oDesktop As IVBShellFolder
    Dim nEaten As Long
    Dim pIdl As Long
    Dim sPath As String
    Dim oMalloc As IVBMalloc

    If Len(Path) > 0 Then
        SHGetDesktopFolder oDesktop
        oDesktop.ParseDisplayName 0, 0, Path, nEaten, pIdl, 0
        sPath = String$(gintMAX_PATH_LEN, 0)
        SHGetPathFromIDListA pIdl, sPath
        SHGetMalloc oMalloc
        oMalloc.Free pIdl
        LongPath = StringFromBuffer(sPath)
    End If
End Function
Public Sub MakeLongPath(Path As String)
    On Error Resume Next
    Path = LongPath(Path)
End Sub

 '-----------------------------------------------------------
 ' FUNCTION GetLongPathName
 '
 ' Retrieve the long pathname version of a path possibly
 '   containing short subdirectory and/or file names
 '-----------------------------------------------------------
 '
 Function GetLongPathName(ByVal strShortPath As String) As String
    On Error GoTo 0
    
    MakeLongPath (strShortPath)
    GetLongPathName = StripTerminator(strShortPath)
 End Function
 
 '-----------------------------------------------------------
 ' FUNCTION GetShortPathName
 '
 ' Retrieve the short pathname version of a path possibly
 '   containing long subdirectory and/or file names
 '-----------------------------------------------------------
 '
 Function GetShortPathName(ByVal strLongPath As String) As String
     Const cchBuffer = 300
     Dim strShortPath As String
     Dim lResult As Long

     On Error GoTo 0
     strShortPath = String(cchBuffer, Chr$(0))
     lResult = OSGetShortPathName(strLongPath, strShortPath, cchBuffer)
     If lResult = 0 Then
         'Error 53 ' File not found
         'Vegas#51193, just use the long name as this is usually good enough
         GetShortPathName = strLongPath
     Else
         GetShortPathName = StripTerminator(strShortPath)
     End If
 End Function
Public Function StringFromBuffer(Buffer As String) As String
    Dim nPos As Long

    nPos = InStr(Buffer, Chr$(0))
    If nPos > 0 Then
        StringFromBuffer = Left$(Buffer, nPos - 1)
    Else
        StringFromBuffer = Buffer
    End If
End Function
Function StripTerminator(ByVal strString As String) As String
    Dim intZeroPos As Integer

    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
    Else
        StripTerminator = strString
    End If
End Function