Paste this into it's own standard module. You can use the fGetUNCPath to
return the the value you need. There are some other procedures that may be
of use as well.
Option Compare Database
Option Explicit
'This code was originally written by Terry Kreft
'and Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Original Code by Terry Kreft
' Modified by Dev Ashish
'
'Drive Types
Global Const DRIVE_UNKNOWN = 0
Global Const DRIVE_ABSENT = 1
Global Const DRIVE_REMOVABLE = 2
Global Const DRIVE_FIXED = 3
Global Const DRIVE_REMOTE = 4
Global Const DRIVE_CDROM = 5
Global Const DRIVE_RAMDISK = 6
' returns errors for UNC Path
Global Const ERROR_BAD_DEVICE = 1200&
Global Const ERROR_CONNECTION_UNAVAIL = 1201&
Global Const ERROR_EXTENDED_ERROR = 1208&
Global Const ERROR_MORE_DATA = 234
Global Const ERROR_NOT_SUPPORTED = 50&
Global Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Global Const ERROR_NO_NETWORK = 1222&
Global Const ERROR_NOT_CONNECTED = 2250&
Global Const NO_ERROR = 0
Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
(ByVal lpszLocalName As String, ByVal _
lpszRemoteName As String, cbRemoteName As Long) As Long
Declare Function GetLogicalDriveStrings Lib "kernel32" Alias
"GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" ( _
ByVal nDrive As String) As Long
Function fGetDrives() As String
'Returns all mapped drives
Dim lngRet As Long
Dim strDrives As String * 255
Dim lngTmp As Long
lngTmp = Len(strDrives)
lngRet = GetLogicalDriveStrings(lngTmp, strDrives)
fGetDrives = Left(strDrives, lngRet)
End Function
Function fGetUNCPath(strDriveLetter As String) As String
On Local Error GoTo fGetUNCPath_Err
Dim Msg As String, lngReturn As Long
Dim lpszLocalName As String
Dim lpszRemoteName As String
Dim cbRemoteName As Long
lpszLocalName = strDriveLetter
lpszRemoteName = String$(255, Chr$(32))
cbRemoteName = Len(lpszRemoteName)
lngReturn = WNetGetConnection(lpszLocalName, lpszRemoteName, _
cbRemoteName)
Select Case lngReturn
Case ERROR_BAD_DEVICE
Msg = "Error: Bad Device"
Case ERROR_CONNECTION_UNAVAIL
Msg = "Error: Connection Un-Available"
Case ERROR_EXTENDED_ERROR
Msg = "Error: Extended Error"
Case ERROR_MORE_DATA
Msg = "Error: More Data"
Case ERROR_NOT_SUPPORTED
Msg = "Error: Feature not Supported"
Case ERROR_NO_NET_OR_BAD_PATH
Msg = "Error: No Network Available or Bad Path"
Case ERROR_NO_NETWORK
Msg = "Error: No Network Available"
Case ERROR_NOT_CONNECTED
Msg = "Error: Not Connected"
Case NO_ERROR
' all is successful...
End Select
If Len(Msg) Then
MsgBox Msg, vbInformation
Else
' fGetUNCPath = Left$(lpszRemoteName, cbRemoteName)
fGetUNCPath = Left$(lpszRemoteName, InStr(lpszRemoteName, Chr(0)) - 1)
End If
fGetUNCPath_End:
Exit Function
fGetUNCPath_Err:
MsgBox Err.Description, vbInformation
Resume fGetUNCPath_End
End Function
Function fDriveType(strDriveName As String) As String
Dim lngRet As Long
Dim strDrive As String
lngRet = GetDriveType(strDriveName)
Select Case lngRet
Case DRIVE_UNKNOWN 'The drive type cannot be determined.
strDrive = "Unknown Drive Type"
Case DRIVE_ABSENT 'The root directory does not exist.
strDrive = "Drive does not exist"
Case DRIVE_REMOVABLE 'The drive can be removed from the drive.
strDrive = "Removable Media"
Case DRIVE_FIXED 'The disk cannot be removed from the drive.
strDrive = "Fixed Drive"
Case DRIVE_REMOTE 'The drive is a remote (network) drive.
strDrive = "Network Drive"
Case DRIVE_CDROM 'The drive is a CD-ROM drive.
strDrive = "CD Rom"
Case DRIVE_RAMDISK 'The drive is a RAM disk.
strDrive = "Ram Disk"
End Select
fDriveType = strDrive
End Function
Sub sListAllDrives()
Dim strAllDrives As String
Dim strTmp As String
strAllDrives = fGetDrives
If strAllDrives <> "" Then
Do
strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) -
1)
strAllDrives = Mid$(strAllDrives, InStr(strAllDrives,
vbNullChar) + 1)
Select Case fDriveType(strTmp)
Case "Removable Media":
Debug.Print "Removable drive : " & strTmp
Case "CD ROM":
Debug.Print " CD Rom drive : " & strTmp
Case "Fixed Drive":
Debug.Print " Local drive : " & strTmp
Case "Network Drive":
Debug.Print " Network drive : " & strTmp
Debug.Print " UNC Path : " & _
fGetUNCPath(Left$(strTmp, Len(strTmp) - 1))
End Select
Loop While strAllDrives <> ""
End If
End Sub
Function UNCDrive(strUNCName As String) As String
'Dave Hargis 9/05
'Returns Drive Letter for UNC drive mapping
Dim strAllDrives As String
Dim varDriveList As Variant
Dim lngDriveIndex As Long
Dim strCurrDrive As String
Dim strPathName As String
strAllDrives = fGetDrives
strAllDrives = Left(strAllDrives, Len(strAllDrives) - 1)
varDriveList = Split(strAllDrives, Chr(0))
lngDriveIndex = UBound(varDriveList) - 1
For lngDriveIndex = 0 To UBound(varDriveList)
strCurrDrive = varDriveList(lngDriveIndex)
If fDriveType(strCurrDrive) = "Network Drive" Then
strPathName = fGetUNCPath(Left(strCurrDrive, Len(strCurrDrive) -
1))
If strUNCName = strPathName Then
UNCDrive = strCurrDrive
Exit For
End If
End If
Next lngDriveIndex
End Function
