Trouble Using VBA Code to map a network drive

Question

Trying to map a network drive letter. Running code shown below. See the last function, function xxx. That's my driver code. That's the one I am running.

Unmapping works. Mapping doesn't work.

Always returns false, means that mapping is never succeeding. User name, password, and path provided seem accurate. Any ideas?

Here is the code:

Option Explicit

Private Const CONNECT_UPDATE_PROFILE = &H1
Private Const RESOURCE_CONNECTED As Long = &H1&
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:", "\\RemoteMachine\RemoteDirectory", "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

      'Old code:
'      MapDrive = (WNetAddConnection2(NetR, Username, Password, _
'        CONNECT_UPDATE_PROFILE) = 0)

  'Edited this question and updated this code due to good input by poster:
  MapDrive = (WNetAddConnection2(NetR, Password, Username, _
    CONNECT_UPDATE_PROFILE) = 0)


    End Function
Public Function UnMapDrive(DriveLetter As String) As Boolean

    Dim NetR As NETCONNECT


With NetR
    .dwScope = RESOURCE_GLOBALNET
    .dwType = RESOURCETYPE_DISK
    .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
    .dwUsage = RESOURCEUSAGE_CONNECTABLE
    .lpLocalName = DriveLetter & ":"
    .lpRemoteName = ""
End With

ChDrive ("C")    ' Ensure that the drive letter to be dropped is not active

UnMapDrive = (WNetCancelConnection2(DriveLetter, CONNECT_UPDATE_PROFILE, True) = 0)


End Function

Here is the driver code:

Public Sub xxx()

    Dim retval As String

    retval = UnMapDrive("S:")
    MsgBox retval

    retval = MapDrive("S:", _
        "\\AFHOUFILE02\User_Folders", _
        "kmistry", "XXXXXX")
    MsgBox retval


End Sub

Answer 1

I found a pretty good solution online that works well on the mapping. Having trouble unmapping, BUT for me, mapping is more important than unmapping. The code I already had before seemed to work well on the unmapping. The combination of the two, gives you a complete solution, although right now, I am not going to take time to gather all that together... Here it is, the code that worked very well on mapping. I hope readers benefit from it:

JUST COPY PASTE THIS INTO A NEW MODULE...:

#If Win64 Then
    Declare PtrSafe Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
    Declare PtrSafe Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
#Else
    Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
    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
#End If


Const CONNECT_UPDATE_PROFILE    As Long = &H1
Const RESOURCE_CONNECTED        As Long = &H1
Const RESOURCE_GLOBALNET        As Long = &H2
Const RESOURCETYPE_DISK         As Long = &H1
Const RESOURCEDISPLAYTYPE_SHARE As Long = &H3
Const RESOURCEUSAGE_CONNECTABLE As Long = &H1


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


Function MapNetworkDrive(ByVal driveLetter As String, ByVal UNC As String) As Boolean
    Dim dl As String * 1
    Dim nc As NETCONNECT

    dl = UCase$(driveLetter)

    nc.dwScope = RESOURCE_GLOBALNET
    nc.dwType = RESOURCETYPE_DISK
    nc.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
    nc.dwUsage = RESOURCEUSAGE_CONNECTABLE
    nc.lpLocalName = driveLetter & ":"
    nc.lpRemoteName = UNC

    MapNetworkDrive = (WNetAddConnection2(nc, vbNullString, vbNullString, CONNECT_UPDATE_PROFILE))

End Function


Function DisconnectNetworkDrive(driveLetter As String) As Boolean
    Dim dl As String * 1
    Dim nc As NETCONNECT

    nc.dwScope = RESOURCE_GLOBALNET
    nc.dwType = RESOURCETYPE_DISK
    nc.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
    nc.dwUsage = RESOURCEUSAGE_CONNECTABLE
    nc.lpLocalName = driveLetter & ":"
    nc.lpRemoteName = vbNullString

    DisconnectNetworkDrive = Not (WNetCancelConnection2(dl, CONNECT_UPDATE_PROFILE, False))
End Function

Answer 2

I see a couple issues with your code and I think there's an easier, more reliable method of programmatically mapping a drive.

---

Try this method instead:

Public Function mapDrive(mdDrive As String, mdRoute As String, _
    Optional mdUserName As String, Optional mdPassword As String) As Boolean

    On Error GoTo catchErr
    Dim mdMapRoute As String, WshNet As Object
    Set WshNet = CreateObject("WScript.Network")

    If mdUserName = "" Then
        WshNet.MapNetworkDrive mdDrive, mdMapRoute
    Else
        If mdPassword = "" Then
            WshNet.MapNetworkDrive mdDrive, mdMapRoute, , mdUserName
        Else
            WshNet.MapNetworkDrive mdDrive, mdMapRoute, , mdUserName, mdPassword
        End If
    End If

catchErr:
    Set WshNet = Nothing
    Select Case Err
        Case 0
            mapDrive = True
        Case -2147024811 'Already mapped
            mapDrive = True
        Case Else
            MsgBox "Error #" & Err & ": " & vbLf & Err.Description
            mapDrive = False
    End Select
End Function

---

Example Usage:

mapDrive "Q:", "\\server\path\sharename\"

---

More Information:

• SmartBear : MapNetworkDrive Method

• Lifewire : Working With the Universal Naming Convention (UNC Path)

• ESRI Devnet : Pathnames explained: Absolute, relative, UNC, and URL

• Wikipedia : Drive Mapping

Answer 3

You're passing the user ID and password in the incorrect order. In your definition:

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

And then in your call:

MapDrive = (WNetAddConnection2(NetR, Username, Password, _
    CONNECT_UPDATE_PROFILE) = 0)

Based on the declaration, the password should precede the username.

Also, your unmap routine is doubling-up the colon on the drive, but it apparently must not be affecting the outcome since you said it's working.