VBA to create a mapped drive

[Rx_]

UPDATE: Found a workaround that reduced the need to try this.
If anyone tries it later, send me PM and I will mark it as Solved

Does anyone have experience in creating a mapped network drive from MSAccess? Any other suggestions over the code listed below?

On my schedule is the ability to Map a Network drive from Access VBA.
In this case, it is assumed that no Administrator PW is needed.

After a google search, this code appears to be used successfully at least on past versions of Windows. My platform is Windows 10.

The problem comes from a post on this site's Excel forum.
My automated Excel VBA reporting system is SaveAs in a directory around 50 characters long (UNC Path). The Excel workbook name includes Date + Report Name + Organization + Division.
If Excel could SaveAs 255 Characters there would not be a problem.
However, the Max Excel length is much, much shorter to accommodate for a max length Worksheet Name (used in links).

One of my options is to use VBA create a Mapped driver R:\ from the UNC path.

This is the best example of code found so far, does anyone else have suggestions?


In a Module - Create a Mapped Drive

Private Const RESOURCE_GLOBALNET As Long = &H2&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
 
Private Declare Function WNetCancelConnection2 Lib "mpr.dll" _
  Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
 
Private Declare Function WNetAddConnection2 Lib "mpr.dll" _
  Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
 
Private Type NETCONNECT
  dwScope As Long
  dwType As Long
  dwDisplayType As Long
  dwUsage As Long
  lpLocalName As String
  lpRemoteName As String
  lpComment As String
  lpProvider As String
End Type
 
Public Function MapDrive(LocalDrive As String, _
  RemoteDrive As String, Optional Username As String, _
  Optional Password As String) As Boolean
 
' Example:
' MapDrive "Q:", "[URL="file://remotemachine/RemoteDirectory"][COLOR=#0066cc]\\RemoteMachine\RemoteDirectory[/COLOR][/URL]", "MyLoginName", "MyPassword"
 
  Dim NetR As NETCONNECT
 
  NetR.dwScope = RESOURCE_GLOBALNET
  NetR.dwType = RESOURCETYPE_DISK
  NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
  NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE
  NetR.lpLocalName = Left(LocalDrive, 1) & ":"
  NetR.lpRemoteName = RemoteDrive
 
  MapDrive = (WNetAddConnection2(NetR, Username, Password, _
    CONNECT_UPDATE_PROFILE) = 0)
 
End Function
 
Public Function UnMapDrive(LocalDrive As String) As Boolean
 
' Example:
' MapDrive "Q:"
 
  Dim NetR As NETCONNECT
 
  NetR.dwScope = RESOURCE_GLOBALNET
  NetR.dwType = RESOURCETYPE_DISK
  NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
  NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE
  NetR.lpLocalName = Left(LocalDrive, 1) & ":"
  NetR.lpRemoteName = ""
 
  UnMapDrive = (WNetCancelConnection2(LocalDrive, _
    CONNECT_UPDATE_PROFILE, False) = 0)
End Function

To Call the above:

MsgBox "Map R: " & MapDrive("R:", _
    "[URL="file://servername/Sharename$/Folder/Subfolder"][COLOR=#0066cc]\\Servername\Sharename$\Folder\Subfolder[/COLOR][/URL]", _
    "administrator", "549221")

Or to call

MsgBox "Map R: " & MapDrive("R:", _
    "[URL="file://192.168.1.18/Sharename$/Folder/Subfolder"][COLOR=#0066cc]\\192.168.1.18\Sharename$\Folder\Subfolder[/COLOR][/URL]", _
    "administrator", "549221")

To disconnect:

MsgBox "Map R: " & MapDrive("R:", _
    "[URL="file://192.168.1.18/Sharename$/Folder/Subfolder"][COLOR=#0066cc]\\192.168.1.18\Sharename$\Folder\Subfolder[/COLOR][/URL]", _
    "administrator", "549221")