VBA Tipp: UNC-Pfad ermitteln

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Ich möchte aus dem Laufwerksbuchstaben eines Netzlaufwerks den UNC-Pfad ermitteln, also den Pfad in der Schreibweise \\Rechnername\Freigabename\ .

Lösung

Private Const RESOURCETYPE_ANY   As Long = &H0
Private Const RESOURCE_CONNECTED As Long = &H1
 
Private Type NETRESOURCE
   dwScope       As Long
   dwType        As Long
   dwDisplayType As Long
   dwUsage       As Long
   lpLocalName   As Long
   lpRemoteName  As Long
   lpComment     As Long
   lpProvider    As Long
End Type
 
Private Declare Function WNetOpenEnum Lib "mpr" _
   Alias "WNetOpenEnumA" ( _
   ByVal dwScope As Long, _
   ByVal dwType As Long, _
   ByVal dwUsage As Long, _
   lpNetResource As Any, _
   lphEnum As Long) As Long
 
Private Declare Function WNetEnumResource Lib "mpr" _
   Alias "WNetEnumResourceA" ( _
   ByVal hEnum As Long, _
   lpcCount As Long, _
   lpBuffer As Any, _
   lpBufferSize As Long) As Long
 
Private Declare Function WNetCloseEnum Lib "mpr" ( _
   ByVal hEnum As Long) As Long
 
Private Declare Function lstrlen Lib "kernel32" _
   Alias "lstrlenA" ( _
   ByVal lpString As Any) As Long
 
Private Declare Function lstrcpy Lib "kernel32" _
   Alias "lstrcpyA" ( _
   ByVal lpString1 As Any, _
   ByVal lpString2 As Any) As Long
 
Public Function LetterToUNC(DriveLetter As String) As String
 
   'Quelle: www.dbwiki.net oder www.dbwiki.de
 
   Dim hEnum As Long
   Dim NetInfo(1023) As NETRESOURCE
   Dim entries       As Long
   Dim nStatus       As Long
   Dim LocalName     As String
   Dim UNCName       As String
   Dim i             As Long
   Dim r             As Long
 
   ' Begin the enumeration
   nStatus = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0&, ByVal 0&, hEnum)
 
   'Check for success from open enum
   If (nStatus = 0) And (hEnum <> 0) Then
      entries = 1024    'Set number of entries
 
      'Enumerate the resource
      nStatus = WNetEnumResource(hEnum, entries, NetInfo(0), _
                                 CLng(Len(NetInfo(0))) * 1024)
 
      'Check for success
      If nStatus = 0 Then
         For i = 0 To entries - 1
            'Get the local name
            LocalName = vbNullString
            If NetInfo(i).lpLocalName <> 0 Then
               LocalName = Space$(lstrlen(NetInfo(i).lpLocalName) + 1)
               r = lstrcpy(LocalName, NetInfo(i).lpLocalName)
            End If
 
            'Strip null character from end
            If Len(LocalName) <> 0 Then _
               LocalName = Left$(LocalName, (Len(LocalName) - 1))
 
            If UCase$(LocalName) = UCase$(DriveLetter) Then
               'Get the remote name
               UNCName = vbNullString
               If NetInfo(i).lpRemoteName <> 0 Then
                  UNCName = Space$(lstrlen(NetInfo(i).lpRemoteName) + 1)
                  r = lstrcpy(UNCName, NetInfo(i).lpRemoteName)
               End If
 
               'Strip null character from end
               If Len(UNCName) <> 0 Then UNCName = Left$(UNCName, (Len(UNCName) - 1))
 
               LetterToUNC = UNCName   'Return the UNC path to drive
               Exit For
            End If
         Next
      End If
   End If
 
   'End enumeration
   WNetCloseEnum hEnum
End Function

Aufruf

   Debug.Print LetterToUNC("L:")
   'Rüchgabe: \\NMA\Toshiba_2_TB

Weblinks