GetUNCName - Convert a file path to a UNC path

' Converts a reference to a file in the standard Windows
' format (e.g. "H:\ServerDir\Filename.ext") in the corresponding UNC
' format (e.g. "\\ServerName\ExportedDir\ServerDir\FileName.txt")
'
' It turns to be very useful when a program running on a workstation
' has to pass a file reference to another app running on another workstation
' or when the file reference should be stored in a database for use from
' every application on the network.

' 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

' This is the main function of the group

Public Function GetUNCName(pathName As String) As String

    Dim os As OSVERSIONINFO
    
    ' determine if we're running under Windows 9x or NT
    os.dwOSVersionInfoSize = Len(os)
    GetVersionEx os
    
    If (os.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) Then
        ' runnning under Windows 9x
        GetUNCName = GetUNCName95(pathName)
    ElseIf (os.dwPlatformId = VER_PLATFORM_WIN32_NT) Then
        ' running under Windows NT
        GetUNCName = GetUNCNameNT(pathName)
    End If
        
End Function

' Private function that does the work under Windows 95

Private Function GetUNCName95(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
    
    ' First of all, verify whether the disk is networked
    If Mid(pathName, 2, 1) = ":" Then
        Dim UNCName As String
        Dim lenUNC As Long
        
        UNCName = String$(260, 0)
        lenUNC = 260
    
        ErrCode = WNetGetConnection(Left(pathName, 2), UNCName, lenUNC)

        If ErrCode = 0 Then
            UNCName = Trim(Left$(UNCName, InStr(UNCName, vbNullChar) - 1))
            GetUNCName95 = UNCName & Mid(pathName, 3)
            Exit Function
        End If
    End If
    
    ' else, scan the registry looking for shared resources (Win9x version)
    computerName = String$(255, 0)
    lComputerName = Len(computerName)
    ErrCode = GetComputerName(computerName, lComputerName)
    If ErrCode <> 1 Then
        GetUNCName95 = pathName
        Exit Function
    End If
    
    computerName = Trim(Left$(computerName, InStr(computerName, _
        vbNullChar) - 1))
    rootKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Network\Lanman"
    ErrCode = RegOpenKey(HKEY_LOCAL_MACHINE, rootKey, hKey)
    If ErrCode <> 0 Then
        GetUNCName95 = pathName
        Exit Function
    End If
    
    i = 0
    Do Until exitFlag
        Dim szValue As String
        Dim szValueName As String
        Dim cchValueName As Long
        Dim szResourceName As String
        Dim cchResourceName As Long
        Dim dwValueType As Long
        Dim dwValueSize As Long
        Dim exitw As Boolean
        Dim Path As String
        Dim j As Double
        
        szResourceName = String(1024, 0)
        cchResourceName = Len(szResourceName)
        
        ' loop on all shared resources
        ErrCode = RegEnumKey(hKey, i, szResourceName, cchResourceName)
                                           
        If ErrCode <> 0 Then
            exitFlag = True
        Else
            ' for each shared resource, read the value looking for PATH
            szResourceName = Trim(Left$(szResourceName, InStr(szResourceName, _
                vbNullChar) - 1))
            key = rootKey & "\" & szResourceName
            RegOpenKey HKEY_LOCAL_MACHINE, key, hKey2
            
            j = 0
            Do Until exitw
                szValue = String$(260, 0)
                dwValueSize = Len(szValue)
                szValueName = String(1024, 0)
                cchValueName = Len(szValueName)
        
                ErrCode = RegEnumValue(hKey2, j, szValueName, cchValueName, 0, _
                    dwValueType, szValue, dwValueSize)
                If ErrCode <> 0 Then
                    exitw = True
                Else
                    szValueName = Trim(Left$(szValueName, InStr(szValueName, _
                        vbNullChar) - 1))
                    If UCase(szValueName) = "PATH" Then
                        ' we found the path the corresponds to the shared 
                        ' resource
                        Path = Trim(Left$(szValue, InStr(szValue, _
                            vbNullChar) - 1))
                        If UCase(Path) = UCase(Left(pathName, Len(Path))) Then
                            GetUNCName95 = "\\" & computerName & "\" & _
                                szResourceName & Mid$(pathName, Len(Path))
                            exitFlag = True
                        End If
                        exitw = True
                    End If
                End If
                j = j + 1
            Loop
            exitw = False
            RegCloseKey hKey2
        End If
        i = i + 1
    Loop
    
    RegCloseKey hKey
    
    If GetUNCName95 = "" Then GetUNCName95 = pathName
    
End Function

' 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