How to copy the network path of the open workbook in Excel 2007 to the clipboard?

Question

I want to write a VBA function for Excel 2007 (as well as Word 2007 and powerpoint 2007) which:

• copies the complete network path of the open workbook or file to the clipboard.

I'm working a lot with files on a network drive and the problem is, that my macro then give out the address with the drive letter like Z:\directory\myfile.xls instead of \\myservername\directory1\directory2\directory\myfile.xls

I'm using the following code:

Sub CopyPathToClipboard()
Dim strPfad As String
Dim mText As DataObject
Set mText = New DataObject

strPfad = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
mText.SetText strPfad
mText.PutInClipboard

End Sub

So I wonder if there could be a way to "resolve" the resulting drive letter to the complete network path to give send the path to other users which have different drive letter definitions.

I found a solution here, but it did not work - I'm getting an error message, so there seems to be missing something or it plain does not work wich Excel 2007.

I tried to invoke the code Lettertounc("Z:"). The resulting error occurs in line LocalName = Space(lstrlen(NetInfo(i).lpLocalName) + 1) and it says (translated) "types are not compatible".
The value of NetInfo(i).lpLocalName is 209899332 at runtime.

I'm working with Windows 7 and Office 2007.

Answer 1

Add this to your code. Then, all you have to do is take Left(strPfad, 2), which should return something like Z:, and pass it into the DriveLetterToUNC function, and it should return an UNC path like \\server\mount.

The declares and the constants have to be at the top of the file, so prepend this text to your code. You should be capable enough of calling the DriveLetterToUNC() function to get the info you need and insert it into your string.

Private Const RESOURCETYPE_ANY = &H0
Private Const RESOURCE_CONNECTED = &H1
Private Type NETRESOURCE
   dwScope As Long
   dwType As Long
   dwDisplayType As Long
   dwUsage As Long
   lpLocalName As Long
   lpRemoteName As Long
   lpComment As Long
   lpProvider As Long
End Type
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias _
   "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, _
   ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) _
   As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias _
   "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, _
   lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" ( _
   ByVal hEnum As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _
   (ByVal lpString As Any) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
   (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Public Function DriveLetterToUNC(Optional DriveLetter As String = "C:") As String
   'converts a given drive letter to the mapped UNC of the local machine
   'eg DriveLetterToUNC("F:")
   '  returns "\\servername\drivename"
   '  or "F:" if not found

   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)

   DriveLetterToUNC = 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
               DriveLetterToUNC = Trim(UNCName)

               ' Exit the loop
               Exit For
            End If
         Next i
      End If
   End If

   ' End enumeration
   nStatus = WNetCloseEnum(hEnum)
End Function