Convert a file path to a UNC path

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: This funciton converts a reference to a file or a directory in the standard Windows format (e.g. "H:\MySubDir") to the corresponding UNC format (e.g. \\MyMachine\MyDir\MySubDir"). This is useful when a program running on a workstation has to pass a file or directory reference to another app running on another workstation or when the reference should be stored in a database for use from every application on the network.

Instructions: Copy the declarations and code below and paste directly into your VB project

' #VBIDEUtils#**************************************************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 6/08/99
' * Time : 10:43
' **************************************************************
' * Comments : Convert a file path to a UNC path
' *
' *
' ********************************************************


' Declares for querying Windows version

Const VER_PLATFORM_WIN32s = 0 'Win32s on Windows 3.1
Const VER_PLATFORM_WIN32_WINDOWS = 1 'Win32 on Windows 95
Const VER_PLATFORM_WIN32_NT = 2 'Win32 on Windows NT

Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "Kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

' Declare for Registry functions

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey _
As String, ByVal ulOptions As Long, ByVal samDesired _
As Long, phkResult As Long) As Long

Private Declare Function RegQueryValue Lib "advapi32.dll" Alias _
"RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal lpValue As String, lpcbValue As Long) As Long

' Note that if you declare lpData as String, then it is
' necessary to pass it with ByVal
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" _
Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex _
As Long, ByVal lpName As String, ByVal cbName As Long) _
As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex _
As Long, ByVal lpValueName As String, lpcbValueName _
As Long, ByVal lpReserved As Long, lpType As Long, _
ByVal lpData As String, lpcbData As Long) As Long

Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function GetComputerName Lib "Kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Private Declare Function WNetGetConnection Lib _
"mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName _
As String, ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long

' Private function that does the work under Windows NT
Private Function GetUNCNameNT(pathName As String) As String

Dim hKey As Long
Dim hKey2 As Long
Dim exitFlag As Boolean
Dim i As Double
Dim ErrCode As Long
Dim rootKey As String
Dim key As String
Dim computerName As String
Dim lComputerName As Long
Dim stPath As String
Dim firstLoop As Boolean
Dim ret As Boolean

' first, verify whether the disk is connected to the network
If Mid(pathName, 2, 1) = ":" Then
Dim UNCName As String
Dim lenUNC As Long

UNCName = String$(520, 0)
lenUNC = 520
ErrCode = WNetGetConnection(Left(pathName, 2), UNCName, lenUNC)

If ErrCode = 0 Then
UNCName = Trim(Left$(UNCName, InStr(UNCName, _
vbNullChar) - 1))
GetUNCNameNT = UNCName & Mid(pathName, 3)
Exit Function
End If
End If

' else, scan the registry looking for shared resources
'(NT version)
computerName = String$(255, 0)
lComputerName = Len(computerName)
ErrCode = GetComputerName(computerName, lComputerName)
If ErrCode <> 1 Then
GetUNCNameNT = pathName
Exit Function
End If

computerName = Trim(Left$(computerName, InStr(computerName, _
vbNullChar) - 1))
rootKey = "SYSTEM\CurrentControlSet\Services\LanmanServer\Shares"
ErrCode = RegOpenKey(HKEY_LOCAL_MACHINE, rootKey, hKey)

If ErrCode <> 0 Then
GetUNCNameNT = pathName
Exit Function
End If

firstLoop = True

Do Until exitFlag
Dim szValue As String
Dim szValueName As String
Dim cchValueName As Long
Dim dwValueType As Long
Dim dwValueSize As Long

szValueName = String(1024, 0)
cchValueName = Len(szValueName)
szValue = String$(500, 0)
dwValueSize = Len(szValue)

' loop on "i" to access all shared DLLs
' szValueName will receive the key that identifies an element
ErrCode = RegEnumValue(hKey, i#, szValueName, _
cchValueName, 0, dwValueType, szValue, dwValueSize)

If ErrCode <> 0 Then
If Not firstLoop Then
exitFlag = True
Else
i = -1
firstLoop = False
End If
Else
stPath = GetPath(szValue)
If firstLoop Then
ret = (UCase(stPath) = UCase(pathName))
stPath = ""
Else
ret = (UCase(stPath) = UCase(Left$(pathName, _
Len(stPath))))
stPath = Mid$(pathName, Len(stPath))
End If
If ret Then
exitFlag = True
szValueName = Left$(szValueName, cchValueName)
GetUNCNameNT = "\\" & computerName & "\" & _
szValueName & stPath
End If
End If
i = i + 1
Loop

RegCloseKey hKey
If GetUNCNameNT = "" Then GetUNCNameNT = pathName

End Function

' support routine

Private Function GetPath(st As String) As String
Dim pos1 As Long, pos2 As Long, pos3 As Long
Dim stPath As String

pos1 = InStr(st, "Path")
If pos1 > 0 Then
pos2 = InStr(pos1, st, vbNullChar)
stPath = Mid$(st, pos1, pos2 - pos1)
pos3 = InStr(stPath, "=")
If pos3 > 0 Then
stPath = Mid$(stPath, pos3 + 1)
GetPath = stPath
End If
End If
End Function