Sub UNCOrdnerauswahl() 
Dim sOrdner, sUNCOrdner As String 
sOrdner = BrowseForFolder("Bitte Ordner auswählen...")
' LW-Mappingnamen ermitteln und auflösen 
sUNCOrdner = LetterToUNC(Left(sOrdner, 2))
sOrdner = Right(sOrdner, Len(sOrdner) - 2)
MsgBox sUNCOrdner & sOrdner, , sOrdner
End Sub 

Function LetterToUNC(DriveLetter As String) As String 
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)
LetterToUNC = DriveLetter
'Check for success from open enum 
If ((nStatus = 0) And (hEnum <> 0)) Then 
  ' Set number of entries 
  entries = 1024
  ' 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 = ""
        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))
        End If 
        If UCase$(LocalName) = UCase$(DriveLetter) Then 
            ' Get the remote name 
            UNCName = ""
            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))
            End If 
            ' Return the UNC path to drive 
            'added the [] to seperate on printout only 
            LetterToUNC = UNCName
            ' Exit the loop 
            Exit For 
        End If 
    Next i
    End If 
End If 
' End enumeration 
nStatus = WNetCloseEnum(hEnum)
End Function