Startseite / Tipps / VB 5/6-Tipp 0605: Path-APIs nutzen

VB 5/6-Tipp 0605: Path-APIs nutzen

 von I. Runge

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'-------------- Anfang Projektdatei Paths.vbp  --------------
'------- Anfang Formular "frmTest" alias frmTest.frm  -------
' Steuerelement: Textfeld "txtSample"

Option Explicit

Private Sub Form_Initialize()
    Dim s As String
    Const b = vbNewLine & vbNewLine
    Const t = "   -->   "
    
    s = "Test der Funktionen von basPaths.bas" & b & b
    
    'Backslash anhängen
    s = s & "AddBackslash(""C:\windows"")" & t & _
        AddBackslash("C:\windows") & b
    
    'Dateiendung anfügen
    s = s & "AddExtension(""C:\autoexec"", "".bat"")" & t & _
        AddExtension("C:\autoexec", ".bat") & b
    
    'Dateiname anfügen
    s = s & "AppendFileName(""C:\windows"", ""wolken.bmp"")" & t & _
        AppendFileName("C:\windows", "wolken.bmp") & b
    
    'Pfad auflösen
    s = s & "ParsePath(""C:\windows\.\system\..\system32\..\wolken.bmp"")" & t & _
        ParsePath("C:\windows\.\system\..\system32\..\wolken.bmp") & b
    
    'Gleiche Teile extrahieren
    s = s & "EqualPart(""C:\windows\wolken.bmp"", ""C:\windows\system\shell32.dll"")" & t & _
        EqualPart("C:\windows\wolken.bmp", "C:\windows\system\shell32.dll") & b
    
    'Pfad verkleinern
    s = s & "CompactPath(""C:\programme\microsoft visual studio\vb98\vb6.exe"", 25)" & t & _
        CompactPath("C:\programme\microsoft visual studio\vb98\vb6.exe", 25) & b
    
    'Prüfen, ob Ordner existiert
    s = s & "FileFolderExists(""C:\windows"")" & t & _
        FileFolderExists("C:\windows") & b
    
    'Prüfen, ob Datei existiert
    s = s & "FileFolderExists(""C:\windows\wolken.bmp"")" & t & _
        FileFolderExists("C:\windows\wolken.bmp") & b
    
    'Prüfen, ob es sich um einen Ordner handelt
    s = s & "IsFolder(""C:\windows"")" & t & _
        IsFolder("C:\windows") & b
    
    'Prüfen, ob Ordner leer ist
    s = s & "IsFolderEmpty(""C:\windows"")" & t & _
        IsFolderEmpty("C:\windows") & b
    
    'Prüfen, ob der Anfang identisch ist
    s = s & "HasPrefix(""C:\windows\system\shell32.dll"", ""D:\eigene Dateien"")" & t & _
        HasPrefix("C:\windows\system\shell32.dll", "D:\eigene Dateien") & b
    
    'Prüfen, ob der Pfad relativ ist
    s = s & "IsRelative(""test.txt"")" & t & IsRelative("test.txt") & b
    
    'Prüfen, ob es sich um ein Root-Verzeichnis handelt
    s = s & "IsRoot(""C:\programme"")" & t & IsRoot("C:\programme") & b
    
    'Prüfen, ob es sich um eine URL handelt
    s = s & "IsURL(""http://www.activevb.de"")" & t & _
        IsURL("http://www.activevb.de") & b
    
    'Prüfen, ob 2 Objekte auf dem gleichen Laufwerk liegen
    s = s & "IsSameDrive(""C:\windows\system"", ""C:\programme"")" & t & _
        IsSameDrive("C:\windows\system", "C:\programme") & b
    
    'Prüfen, ob es sich um einen Netzwerkpfad handelt
    s = s & "IsNetworkPath(""\\Server\Freigabe\test.doc"")" & t & _
        IsNetworkPath("\\Server\Freigabe\test.doc") & b
    
    'Anführungszeichen einfügen (Wenn nötig)
    s = s & "Quote(""C:\programme\microsoft visual studio\vb98\vb6.exe"")" & t & _
        Quote("C:\programme\microsoft visual studio\vb98\vb6.exe") & b
    
    'Anführungszeichen einfügen (Wenn nötig)
    s = s & "Quote(""C:\windows\system"")" & t & Quote("C:\windows\system") & b
    
    'Anführungszeichen entfernen
    s = s & "UnQuote(""""""C:\programme\microsoft visual studio\vb98\vb6.exe"""""")" & t & _
        UnQuote("""C:\programme\microsoft visual studio\vb98\vb6.exe""") & b
    
    'Anführungszeichen entfernen
    s = s & "GetRoot(""D:\eigene dateien\meine programme"")" & t & _
        GetRoot("D:\eigene dateien\meine programme") & b
    
    'Pfad in kurzen Pfad umwandeln
    s = s & "GetShortPathName(""" & App.Path & "\frmTest.frm"")" & t & _
        GetShortPathName(App.Path & "\frmTest.frm") & b
    
    'Pfad in langen Pfad umwandeln
    s = s & "GetLongPathName(""" & GetShortPathName(App.Path & "\frmTest.frm") & """)" & t & _
        GetLongPathName(GetShortPathName(App.Path & "\frmTest.frm")) & b
    
    txtSample.Text = s
End Sub

Private Sub Form_Resize()
    txtSample.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
'-------- Ende Formular "frmTest" alias frmTest.frm  --------
'-------- Anfang Modul "basPaths" alias basPaths.bas --------

Option Explicit


' Code by I.Runge (mastermind@ircastle.de)
Private Declare Function PathAddBackslash Lib "shlwapi.dll" _
                         Alias "PathAddBackslashA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathAddExtension Lib "shlwapi.dll" _
                         Alias "PathAddExtensionA" ( _
                         ByVal pszPath As String, _
                         ByVal pszExt As String) As Long
                         
Private Declare Function PathAppend Lib "shlwapi.dll" _
                         Alias "PathAppendA" ( _
                         ByVal pszPath As String, _
                         ByVal pMore As String) As Long
                         
Private Declare Function PathCanonicalize Lib "shlwapi.dll" _
                         Alias "PathCanonicalizeA" ( _
                         ByVal pszBuf As String, _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathCommonPrefix Lib "shlwapi.dll" _
                         Alias "PathCommonPrefixA" ( _
                         ByVal pszFile1 As String, _
                         ByVal pszFile2 As String, _
                         ByVal achPath As String) As Long
                         
Private Declare Function PathCompactPathEx Lib "shlwapi.dll" _
                         Alias "PathCompactPathExA" ( _
                         ByVal pszOut As String, _
                         ByVal pszSrc As String, _
                         ByVal cchMax As Long, _
                         ByVal dwFlags As Long) As Long
                         
Private Declare Function PathFileExists Lib "shlwapi.dll" _
                         Alias "PathFileExistsA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsDirectory Lib "shlwapi.dll" _
                         Alias "PathIsDirectoryA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsDirectoryEmpty Lib "shlwapi.dll" _
                         Alias "PathIsDirectoryEmptyA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsPrefix Lib "shlwapi.dll" _
                         Alias "PathIsPrefixA" ( _
                         ByVal pszPrefix As String, _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsRelative Lib "shlwapi.dll" _
                         Alias "PathIsRelativeA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsRoot Lib "shlwapi.dll" _
                         Alias "PathIsRootA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsSameRoot Lib "shlwapi.dll" _
                         Alias "PathIsSameRootA" ( _
                         ByVal pszPath1 As String, _
                         ByVal pszPath2 As String) As Long
                         
Private Declare Function PathIsURL Lib "shlwapi.dll" _
                         Alias "PathIsURLA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function PathIsUNC Lib "shlwapi.dll" _
                         Alias "PathIsUNCA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Sub PathQuoteSpaces Lib "shlwapi.dll" _
                    Alias "PathQuoteSpacesA" ( _
                    ByVal lpsz As String)
                    
Private Declare Sub PathUnquoteSpaces Lib "shlwapi.dll" _
                    Alias "PathUnquoteSpacesA" ( _
                    ByVal lpsz As String)
                    
Private Declare Function PathStripToRoot Lib "shlwapi.dll" _
                         Alias "PathStripToRootA" ( _
                         ByVal pszPath As String) As Long
                         
Private Declare Function GetFullPathName Lib "kernel32" _
                         Alias "GetFullPathNameA" ( _
                         ByVal lpFileName As String, _
                         ByVal nBufferLength As Long, _
                         ByVal lpBuffer As String, _
                         ByVal lpFilePart As String) As Long
                         
Private Declare Function APIGetShortPathName Lib "kernel32" _
                         Alias "GetShortPathNameA" ( _
                         ByVal lpszLongPath As String, _
                         ByVal lpszShortPath As String, _
                         ByVal cchBuffer As Long) As Long

Public Function AddBackslash(ByVal Path As String) As String
    ' Sicherstellen, dass sich am Ende des Pfades ein \
    ' befindet, also nicht "C:\windows", sondern "C:\windows\"
    Dim sBuf As String
    sBuf = Path + String(100, 0)
    Call PathAddBackslash(sBuf)
    AddBackslash = RemNulls(sBuf)
End Function

Public Function AddExtension(ByVal FileName As String, ByVal Extension As String) As String
    ' Sicherstellen, dass sich am Ende des Dateinamens eine Dateiendung
    ' befindet, also nicht "C:\autoexec", sondern "C:\autoexec.bat"
    ' Extension ist z.B. ".bat" oder ".txt"
    Dim sBuf As String
    sBuf = FileName + String(100, 0)
    Call PathAddExtension(sBuf, Extension)
    AddExtension = RemNulls(sBuf)
End Function

Public Function AppendFileName(ByVal Path As String, ByVal FileName As String) As String
    ' Hängt einen Dateinamen (FileName) wie "test.txt" an einen
    ' Pfad (Path) z.B. "C:\windows\" oder "C:\windows" an.
    Dim sBuf As String
    sBuf = Path + String(100, 0)
    Call PathAppend(sBuf, FileName)
    AppendFileName = RemNulls(sBuf)
End Function

Public Function ParsePath(ByVal Path As String) As String
    ' Macht aus einem Pfad mit relativen Angaben wie z.B.
    ' "C:\windows\.\system32\..\wolken.bmp" einen absoluten wie
    ' "C:\windows\wolken.bmp"
    Dim sBuf As String
    sBuf = Space(255)
    Call PathCanonicalize(sBuf, Path)
    ParsePath = RemNulls(sBuf)
End Function

Public Function EqualPart(ByVal Path1 As String, ByVal Path2 As String) As String
    ' Gibt den gemeinsamen Teil von zwei Pfaden zurück, z.B.
    ' Path1="C:\windows\system\shell32.dll" und Path2="C:\windows\wolken.bmp"
    ' dann ist der Rückgabewert "C:\windows"
    Dim sBuf As String
    sBuf = String(255, 0)
    Call PathCommonPrefix(Path1, Path2, sBuf)
    EqualPart = RemNulls(sBuf)
End Function

Public Function CompactPath(ByVal Path As String, ByVal MaxChars As Long)
    ' Kürzt den Pfad auf MaxChars Zeichen, aus
    ' "C:\Programme\Microsoft Visual Studio\VB98"
    ' wird z.B. "C:\Progr...\VB98
    Dim sBuf As String
    sBuf = String(255, 0)
    Call PathCompactPathEx(sBuf, Path, MaxChars, 0&)
    CompactPath = RemNulls(sBuf)
End Function

Public Function FileFolderExists(ByVal Path As String) As Boolean
    ' Stellt fest, ob ein Ordner oder eine Datei existiert
    FileFolderExists = CBool(PathFileExists(Path))
End Function

Public Function IsFolder(ByVal Path As String) As Boolean
    ' Stellt fest, ob Path ein Ordner ist
    IsFolder = CBool(PathIsDirectory(Path))
End Function

Public Function IsFolderEmpty(ByVal Path As String) As Boolean
    ' Stellt fest, ob ein Ordner leer ist
    IsFolderEmpty = CBool(PathIsDirectoryEmpty(Path))
End Function

Public Function HasPrefix(ByVal Path As String, ByVal Prefix As String) As Boolean
    ' Stellt fest, ob ein Pfad das Prefix hat
    HasPrefix = CBool(PathIsPrefix(AddBackslash(Prefix), Path))
End Function

Public Function IsRelative(ByVal Path As String) As Boolean
    ' Stellt fest, ob ein Pfad relativ oder absolut ist
    IsRelative = CBool(PathIsRelative(Path))
End Function

Public Function IsRoot(ByVal Path As String) As Boolean
    ' Stellt fest, ob ein Pfad wie "C:\" oder
    ' wie "C:\windows" ist
    IsRoot = CBool(PathIsRoot(Path))
End Function

Public Function IsURL(ByVal Path As String) As Boolean
    ' Stellt fest, ob Path eine Internet-Adresse ist
    IsURL = CBool(PathIsURL(Path))
End Function

Public Function IsSameDrive(ByVal Path1 As String, ByVal Path2 As String) As Boolean
    ' Stellt fest, ob die Pfade auf dem selben Laufwerk liegen
    IsSameDrive = CBool(PathIsSameRoot(Path1, Path2))
End Function

Public Function IsNetworkPath(ByVal Path As String) As Boolean
    ' Stellt fest, ob Path eine Netzwerk-Adresse ist
    IsNetworkPath = CBool(PathIsUNC(Path))
End Function

Public Function UnQuote(ByVal Path As String) As String
    ' Entfernt evtl. vorhandene Anführungszeichen
    Dim sBuf As String
    sBuf = Path + String(100, 0)
    Call PathUnquoteSpaces(sBuf)
    UnQuote = RemNulls(sBuf)
End Function

Public Function Quote(ByVal Path As String) As String
    ' Wenn in Path Leerzeichen vorkommen, Anführungszeichen setzen
    Dim sBuf As String
    sBuf = Path + String(100, 0)
    Call PathQuoteSpaces(sBuf)
    Quote = RemNulls(sBuf)
End Function

Public Function GetRoot(ByVal Path As String) As String
    ' Gibt das Laufwerk zurück, z.B. "C:\"
    Dim sBuf As String
    sBuf = Path + String(100, 0)
    Call PathStripToRoot(sBuf)
    GetRoot = RemNulls(sBuf)
End Function

Public Function GetShortPathName(ByVal Path As String)
    ' Gibt den verkürzten Pfad im 8.3-Format zurück
    ' ACHTUNG! Geht nur mit tatsächlich existierenden Dateien!
    Dim sBuf As String
    sBuf = Space(255)
    Call APIGetShortPathName(Path, sBuf, Len(sBuf))
    GetShortPathName = RemNulls(sBuf)
End Function

Public Function GetLongPathName(ByVal Path As String)
    ' Wandelt einen Pfad im 8.3-Format ins "normale" zurück
    ' ACHTUNG! Geht nur mit tatsächlich existierenden Dateien!
    Dim sBuf As String
    sBuf = String(255, 0)
    Call GetFullPathName(Path, Len(sBuf), sBuf, vbNullString)
    GetLongPathName = RemNulls(sBuf)
End Function

Private Function RemNulls(ByVal sStr As String) As String
    ' Entfernt die Nullzeichen am Ende eines Strings
    Dim lPos As Long
    lPos = InStr(1, sStr, vbNullChar)
    If lPos > 0 Then
        RemNulls = Left(sStr, lPos - 1)
    Else
        RemNulls = sStr
    End If
End Function
'--------- Ende Modul "basPaths" alias basPaths.bas ---------
'--------------- Ende Projektdatei Paths.vbp  ---------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Private Declare Function GetLongPathName Lib "kernel32" Alias _
                        "GetLongPathNameA" (ByVal lpszShortPath As  _
                        String, _
                         ByVal lpszLongPath As String, _
                         ByVal cchBuffer As Long) As Long