Convert network UNC file path to the local drive reference path

[killpaddy]

I am referencing files from a network drive, however it may be mapped as different letter drives on different users computers e.g. L:\ or R:\.

Is there a way of finding what the drive has been mapped as on the users pc using the UNC file path e.g. \\server\folder\folder\file.xlsm
Ideally I would like to convert a UNC file path string to a local drive letter file path string.

I have found examples of the reverse of this, converting the local drive letter path to a UNC path, but cannot work out how to achieve what I have asked.

Thanks

 

[jimrward]

you could use the following to get drive and unc and do your own logic test to match accordingly, bit clunky but its a start

Sub ListNetworkDrives()
Set objNetwork = CreateObject("WScript.Network")
Set objdrives = objNetwork.EnumNetworkDrives
strDrives = "Network drive Mappings:" & Chr(13)
For i = 0 To objdrives.Count - 1 Step 2
strDrives = strDrives & "Drive " & objdrives.Item(i) & " = " & objdrives.Item(i + 1) & Chr(13)
mylet = objdrives.Item(i)
myunc = objdrives.Item(i + 1)
Next
MsgBox strDrives

End Sub

 

[killpaddy]

Thats an excellent start, thanks. Guess there's no simple function just to convert between the two filepath types.

I'll have a go at making a function to convert an input filepath to an output filepath of another type using this code and post back here.

 

[killpaddy]

Here is my first attempt at the function to convert the path string to the other type.

It is causing an error on the indicated line and I'm not sure what the problem is, can anyone help?

after adding a watch on 'objdrives' I have found it working and is populated with strings in the 'Value' column of each item.

I guess the error is to do with how attempting to call the value (with the '.Item(i).Value') part, but I don't know what the correct way is???

Function CONVERTPATH(ByRef Path As String, UNC As Boolean)


Dim PathDrive As String
Dim ConvDrive As String


Dim NetDrive1 As String
Dim NetDrive2 As String


Dim TWO As Integer
Dim ConvPath As String


If UNC = True Then
    PathDrive = Replace(left(Path, InStr(1, Replace(Path, "\", "?", 1, 3), "\") - 1), "?", "\")
Else
    PathDrive = left(Path, InStr(1, Path, "\") - 1)
End If


    Set objNetwork = CreateObject("WScript.Network")
    Set objdrives = objNetwork.EnumNetworkDrives
    strDrives = "Network drive Mappings:" & Chr(13)
    NonFound = 0
    For i = 0 To objdrives.Count - 1 Step 2
        NetDrive1 = objdrives.Item(i).Value                   '< error here run time 424, object required
<runtime error="" 424,="" object="" required
        NetDrive2 = objdrives.Item(i + 1).Value
        If NetDrive1 = PathDrive Then
            ConvDrive = NetDrive2
            Exit For
        ElseIf NetDrive2 = PathDrive Then
            ConvDrive = NetDrive1
            Exit For
        Else
            NonFound = NonFound + 1
        End If
    Next
    
If (objdrives.Count / TWO) < NonFound + 2 Then MsgBox ("Drive in file path not recognised")
ConvPath = ConvDrive & Right(Path, Len(Path) - PathDrive)


Path = ConvPath


End Function

</runtime>

 

[killpaddy]

It's not letting me post the rest of my code above, here's the rest:

        NetDrive2 = objdrives.Item(i + 1).Value
        If NetDrive1 = PathDrive Then
            ConvDrive = NetDrive2
            Exit For
        ElseIf NetDrive2 = PathDrive Then
            ConvDrive = NetDrive1
            Exit For
        Else
            NonFound = NonFound + 1
        End If
    Next
TWO = 2
If (objdrives.Count / TWO) < NonFound + 2 Then MsgBox ("Drive in file path not recognised")
ConvPath = ConvDrive & Right(Path, Len(Path) - PathDrive)


Path = ConvPath


End Function

 

[phillfri]

Convert UNC full file name to local mapped drive full file name.

'''''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|'''|
''--------------------------------------------------------------------------------------------
'' Function : GetDrvLtrFileName
'' Author : Phillip M. Fries
'' Date : 2/11/2016
'' Purpose : Convert a URL file name to a local machine shared drive letter file name.
'' : If the URL file name does not match a local machine shared drive, then
'' : "" is returned.
'' :
'' Parameters : SN = URL File Name as a string
''--------------------------------------------------------------------------------------------
''
Public Function GetDrvLtrFileName(SN As String)
Dim fs As Object
Dim dr As Object
Dim sURLLastFldr As String
Dim ctr As Integer
Dim x As Long
Dim y As Long
Dim TempTxt1 As String
Dim TempTxt2 As String
Dim myArray As Variant
Dim List As String
Dim Hold As String
Dim sURL As Variant
Dim sDrvLtr As String

10 Application.EnableCancelKey = xlErrorHandler
20 On Error GoTo ErrorHandler

'Get scripting filesystem object and loop through attached drives.
'Create a delimited string of the drive share names with drive
'letter appended to end of the drive share name. The List is added
'to only if a drive share name is found in the passed file name.
30 Set fs = CreateObject("Scripting.fileSystemObject")
40 For Each dr In fs.Drives
50 If Len(dr.sharename) > 0 And InStr(SN, dr.sharename) Then
60 List = List & dr.sharename & dr.driveletter & ";"
70 End If
80 Next

'If matching shares were found, process them
90 If Len(List) > 0 Then

'Convert the List string into a variant array
100 List = Left(List, Len(List) - 1)
110 myArray = Split(List, ";")

'Check if the array contains more than 1 share entry. If so, sort
'the array alphabetically. This places the longest matching share
'name found into the last entry in the array.
120 If UBound(myArray) > 0 Then
130 For x = LBound(myArray) To UBound(myArray)
140 For y = x To UBound(myArray)
150 If UCase(myArray) < UCase(myArray(x)) Then
160 TempTxt1 = myArray(x)
170 TempTxt2 = myArray
180 myArray(x) = TempTxt2
190 myArray = TempTxt1
200 End If
210 Next y
220 Next x
230 End If

'Loop through array entries from last to first. Compare the last folder in each
'share name against the passed file name. When a match is found we have the
'share name and appended drv ltr we need. Construct the equivalent drv ltr file
'name of the url file name passed to this routine.
240 For ctr = UBound(myArray) To 0 Step -1
250 sURLLastFldr = Right(myArray(ctr), Len(myArray(ctr)) - InStrRev(myArray(ctr), "\") + 1)
260 Hold = Left(sURLLastFldr, Len(sURLLastFldr) - 1)
270 If InStr(SN, Hold) Then
280 sURL = Left(myArray(ctr), Len(myArray(ctr)) - 1)
290 sDrvLtr = Right(sURLLastFldr, 1)
300 GetDrvLtrFileName = Replace(SN, sURL, sDrvLtr & ":", 1, 1)
310 Exit Function
320 End If
330 Next ctr
340 End If

ExitCode:
350 Application.EnableEvents = True
360 Application.ScreenUpdating = True
370 On Error GoTo 0
380 Exit Function
ErrorHandler:
390 Select Case Err.Number
Case Is = 18
'Disallow "Cancel" or "Ctrl-Break"
400 Resume
410 Case Is > 10000
'Handle custom err.raise
420 Case Else
'Global error handler
430 ErrHandler Err.Source, ThisWorkbook.FullName, ActiveWorkbook.FullName, _
ActiveSheet.Name, "VBAProject", "mUtilities", "GetDrvLtrFileName", _
Erl, Err.Number, Err.Description
440 GoTo ExitCode
450 End Select
End Function