Used to perform mapping functions in Access or Excel VBA for network drives.

NetworkDrive.cls

' Copyright (C) 2016 Mike Rourke

' Permission is hereby granted, free of charge, to any person obtaining a copy 
' of this software and associated documentation files (the "Software"), to deal 
' in the Software without restriction, including without limitation the rights 
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 
' copies of the Software, and to permit persons to whom the Software is 
' furnished to do so, subject to the following conditions:

' The above copyright notice and this permission notice shall be included in 
' all copies or substantial portions of the Software.

' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 
' THE SOFTWARE.

'
' Used to perform mapping functions and validation for network drives.  I used
'     Windows API calls to avoid dependency on the Windows Script Host Object
'     Model reference.  The "@article" tags indicate the link address on MSDN.
'     For example, for the "WNetAddConnection2" function, replace [@article]
'     from the link below with "aa385413".
' @author Mike Rourke
' @date 11/30/2016
' @see https://msdn.microsoft.com/en-us/library/windows/desktop/[@article](v=vs.85).aspx
' @todo Write tests.
'

Option Compare Database
Option Explicit

Private Const MODULE_NAME As String = "NetworkDrive"

' Constant for WNet- API Calls:
' CONNECT_UPDATE_PROFILE and RESOURCETYPE_DISK
Private Const API_FLAG = &H1

' Windows API Function Calls:
' @article aa385413
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias _
    "WNetAddConnection2A" (lpNetResource As NETRESOURCE, _
    ByVal lpPassword As String, ByVal lpUsername As String, _
    ByVal dwFlags As Long) As Long
    
' @article aa385423
Private Declare Function WNetCancelConnection Lib "mpr.dll" _
   Alias "WNetCancelConnectionA" (ByVal lpName As String, _
   ByVal dwFlags As Long, ByVal fForce As Long) As Long

' @article aa385453
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _
    "WNetGetConnectionA" (ByVal lpszLocalName As String, _
    ByVal lpszRemoteName As String, lngRemoteName As Long) As Long

' @article aa364975
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
    "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long

' @article aa364939
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
    
' Drive Types returned from GetDriveType API call:
' @article bb776410
Private Enum DriveType
    UNKNOWN_TYPE = 0
    ABSENT = 1
    REMOVABLE = 2
    FIXED = 3
    REMOTE = 4
    DISC = 5
    RAMDISK = 6
End Enum

' System Error Codes returned by the WNet- API calls:
' @article ms681381
Private Enum SystemErrorCode
    ERROR_SUCCESS = 0
    ERROR_ACCESS_DENIED = 5
    ERROR_NOT_SUPPORTED = 50
    ERROR_NETWORK_ACCESS_DENIED = 65
    ERROR_BAD_DEV_TYPE = 66
    ERROR_BAD_NET_NAME = 67
    ERROR_ALREADY_ASSIGNED = 85
    ERROR_INVALID_PASSWORD = 86
    ERROR_BUSY = 170
    ERROR_CANCEL_VIOLATION = 173
    ERROR_MORE_DATA = 234
    ERROR_BAD_DEVICE = 1200
    ERROR_CONNECTION_UNAVAIL = 1201
    ERROR_DEVICE_ALREADY_REMEMBERED = 1202
    ERROR_NO_NET_OR_BAD_PATH = 1203
    ERROR_BAD_PROVIDER = 1204
    ERROR_CANNOT_OPEN_PROFILE = 1205
    ERROR_BAD_PROFILE = 1206
    ERROR_EXTENDED_ERROR = 1208
    ERROR_SESSION_CREDENTIAL_CONFLICT = 1219
    ERROR_NO_NETWORK = 1222
    ERROR_NOT_CONNECTED = 2250
    ERROR_OPEN_FILES = 2401
    ERROR_DEVICE_IN_USE = 2404
End Enum

' @article aa385353
Private Type NETRESOURCE
    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

Private m_driveName As String
Private m_desiredPath As String

Public Property Let DriveName(ByVal rhValue As String)
    m_driveName = rhValue
End Property

Public Property Let DesiredPath(ByVal rhValue As String)
    m_desiredPath = rhValue
End Property

'
' Returns the drive name of the first mappable drive that's available.  The
'     drives are evaluated alphabetically.
' @returns {String} Drive name for the first available drive.
'
Public Property Get GetFirstAvailable() As String
On Error GoTo Catch

    Dim listOfMappedDrives As String
    listOfMappedDrives = GetListOfMappedDrives
    
    Dim charIndex As Integer
    For charIndex = 68 To 90 ' Skip A, B, and C
        Dim nameOfDrive As String
        nameOfDrive = Chr(charIndex) & ":"
        
        If (GetDriveType(nameOfDrive) = DriveType.ABSENT) Then
            GetFirstAvailable = nameOfDrive
            Exit Property
        End If
    Next charIndex

Finally:
    Exit Property

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "GetFirstAvailable"
    Resume Finally
    
End Property

'
' Disconnects the specified drive name.  If the drive isn't mapped, return
'     True.
' @param {Boolean} [isSilent] If True, disconnect the mapped drive without
'     displaying prompts.
' @returns {Boolean} True if the drive was successfully disconnected.
'
Public Function Disconnect(Optional ByVal isSilent As Boolean) As Boolean
On Error GoTo Catch

    If Not (ValidatePropertyAssignments) Then
        Exit Function
    End If
    
    ' This is just an extra validation step.  If the drive isn't mapped in
    ' the first place, it's technically disconnected:
    If (Me.IsAvailableForMapping) Then
        Disconnect = True
        Exit Function
    End If
    
    Dim returnCode As SystemErrorCode
    returnCode = WNetCancelConnection(m_driveName, API_FLAG, False)
    
    If (returnCode = SystemErrorCode.ERROR_SUCCESS) Then
        If Not (isSilent) Then
            MsgBox "Drive successfully disconnected.", vbInformation, "Success"
        End If
        Disconnect = True
    Else
    End If

Finally:
    Exit Function

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, "Disconnect"
    Resume Finally
    
End Function

'
' Evaluates the drive name to determine if the corresponding path
'     matches the the desired drive path.  If it doesn't or the drive
'     isn't mapped, the user is prompted with a confirmation message box
'     to perform the mapping.  If accepted, the drive is mapped to the
'     specified path.
' @param {Boolean} [isSilent] If True, perform the mapping without displaying
'     prompts.
' @returns {Boolean} True if the mapping was successful.
'
Public Function Map(Optional ByVal isSilent As Boolean) As Boolean
On Error GoTo Catch

    If Not (ValidatePropertyAssignments(isPathRequired:=True)) Then
        Exit Function
    End If
    
    Dim returnCode As SystemErrorCode
    returnCode = GetConnectionDetails(0)
    
    If (WasApiCallSuccessful(returnCode)) Then
        Dim response As VbMsgBoxResult
        If (isSilent) Then
            response = vbYes
        Else
            response = ResponseToConfirmation(returnCode)
        End If
        
        If (response = vbYes) Then
            Disconnect isSilent:=isSilent
            Map = (MapDriveToPath)
        End If
    End If

Finally:
    Exit Function

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, "Map"
    Resume Finally

End Function

'
' If the connection code for the API call returned either an existing mapping
'     that didn't match the desired path or an available drive, confirm the
'     mapping action.
' @param {SystemErrorCode} returnCode Connection code from API call.
' @returns {VbMsgBoxResult} Result of MsgBox prompt.
'
Private Function ResponseToConfirmation(ByVal returnCode As SystemErrorCode) _
                                        As VbMsgBoxResult
On Error GoTo Catch

    Dim message As String
    If (returnCode = SystemErrorCode.ERROR_SUCCESS) Then
        message = "The " & m_driveName & " drive is not mapped to the correct" _
                & " location.  The current mapping will be disconnected to" _
                & " fix this issue.  Would you like to proceed?"
        
    ElseIf (returnCode = SystemErrorCode.ERROR_NOT_CONNECTED) Then
        message = "You are not mapped to the " & m_driveName & " drive.  " _
                & "Would you like to map it?"
    
    Else
        Exit Function
    End If
    
    ResponseToConfirmation = MsgBox(message, vbYesNo + vbQuestion, _
                                    "Confirmation")

Finally:
    Exit Function

Catch:
    ResponseToConfirmation = vbNo
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "ResponseToConfirmation"
    Resume Finally

End Function

'
' Maps the specified drive name to the specified drive path.  Returns True if
'     the drive was successfully mapped.  The API call code was taken from
'     {http://www.andreavb.com/tip030017.html} and modified to match my
'     coding conventions.
' @param {String} [username] Optional username for mapping drive.
' @param {String} [password] Optional password for mapping drive.
' @returns {Boolean} True if the drive was successfully disconnected.
' @example
' MapDriveToPath "F:", "\\mydrive\share"
'
Private Function MapDriveToPath(Optional ByVal username As String, _
                                Optional ByVal password As String) _
                                As Boolean
On Error GoTo Catch

    Dim lpNetResource As NETRESOURCE
    With lpNetResource
        .dwType = API_FLAG
        .lpLocalName = m_driveName & Chr(0)
        .lpRemoteName = m_desiredPath & Chr(0)
        .lpProvider = Chr(0)
    End With
    
    Dim returnCode As SystemErrorCode
    returnCode = WNetAddConnection2(lpNetResource, password, username, _
                                    API_FLAG)
    
    If (WasApiCallSuccessful(returnCode)) Then
        MapDriveToPath = (Me.IsMappedCorrectly)
    End If
    
    If Not (MapDriveToPath) Then
        MsgBox "The desired path was not mapped.", vbCritical, "Error"
    End If

Finally:
    Exit Function

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, "MapDriveToPath"
    Resume Finally

End Function

'
' Prompts the user with an error message if the result of the WNet API call
'     is for an error.
' @param {SystemErrorCode} returnCode Connection code from API call.
' @returns {Boolean} True if an error occurred.
'
Private Function WasApiCallSuccessful(ByVal returnCode As SystemErrorCode) _
                 As Boolean
On Error GoTo Catch
    
    Dim errorMessage As String
    errorMessage = GetErrorMessageForApiCall(returnCode)
    
    WasApiCallSuccessful = (errorMessage = "")
    
    If Not (WasApiCallSuccessful) Then
        errorMessage = errorMessage & vbCrLf & "ERROR CODE: " & returnCode
        MsgBox errorMessage, vbCritical, "Error"
    End If

Finally:
    Exit Function

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "WasApiCallSuccessful"
    Resume Finally
    
End Function

'
' Returns an error message based on the result of the WNetGetConnection API
'     call.
' @param {SystemErrorCode} returnCode Connection code from API call.
' @returns {String} Error message to display to the user.
'
Private Property Get GetErrorMessageForApiCall( _
                     ByVal returnCode As SystemErrorCode) As String
On Error Resume Next

    Dim errorMessage As String

    Select Case returnCode
    Case ERROR_ACCESS_DENIED '[5]
        errorMessage = "Access is denied."
    Case ERROR_NOT_SUPPORTED '[50]
        errorMessage = "The request is not supported."
    Case ERROR_NETWORK_ACCESS_DENIED '[65]
        errorMessage = "Network access is denied."
    Case ERROR_BAD_DEV_TYPE '[66]
        errorMessage = "The network resource type is not correct."
    Case ERROR_BAD_NET_NAME '[67]
        errorMessage = "The network name cannot be found."
    Case ERROR_ALREADY_ASSIGNED '[85]
        errorMessage = "The local device name is already in use."
    Case ERROR_INVALID_PASSWORD '[86]
        errorMessage = "The specified network password is not correct."
    Case ERROR_BUSY '[170]
        errorMessage = "The requested resource is in use."
    Case ERROR_CANCEL_VIOLATION '[173]
        errorMessage = "A lock request was not outstanding for the supplied" _
                     & " cancel region."
    Case ERROR_MORE_DATA '[234]
        errorMessage = "More data is available."
    Case ERROR_BAD_DEVICE '[1200]
        errorMessage = "The specified device name is invalid."
    Case ERROR_CONNECTION_UNAVAIL '[1201]
        errorMessage = "The device is not currently connected but it is a" _
                     & " remembered connection."
    Case ERROR_DEVICE_ALREADY_REMEMBERED '[1202]
        errorMessage = "The local device name has a remembered connection" _
                     & " to another network resource."
    Case ERROR_NO_NET_OR_BAD_PATH '[1203]
        errorMessage = "The network path was either typed incorrectly, does" _
                     & " not exist, or the network provider is not currently" _
                     & " available. Please try retyping the path or contact" _
                     & " your network administrator."
    Case ERROR_BAD_PROVIDER '[1204]
        errorMessage = "The specified network provider name is invalid."
    Case ERROR_CANNOT_OPEN_PROFILE '[1205]
        errorMessage = "Unable to open the network connection profile."
    Case ERROR_BAD_PROFILE '[1206]
        errorMessage = "The network connection profile is corrupted."
    Case ERROR_EXTENDED_ERROR '[1208]
        errorMessage = "An extended error has occurred."
    Case ERROR_SESSION_CREDENTIAL_CONFLICT '[1209]
        errorMessage = "Multiple connections to a server or shared resource" _
                     & " by the same user, using more than one user name," _
                     & " are not allowed. Disconnect all previous" _
                     & " connections the server or shared resource and try" _
                     & " again."
    Case ERROR_NO_NETWORK '[1222]
        errorMessage = "The network is not present or not started."
    Case ERROR_OPEN_FILES '[2401]
        errorMessage = "This network connection has files open or requests" _
                     & " pending."
    Case ERROR_DEVICE_IN_USE '[2404]
        errorMessage = "The device is in use by an active process and cannot" _
                     & " be disconnected."
    Case Else
        ' Do nothing
    End Select
    
    GetErrorMessageForApiCall = errorMessage
    
End Property

Public Property Get IsMappedCorrectly() As Boolean
On Error Resume Next

    If Not (ValidatePropertyAssignments(isPathRequired:=True)) Then
        Exit Property
    End If
    
    IsMappedCorrectly = (GetConnectionDetails(1) = m_desiredPath)
    
End Property

'
' Returns True if the drive can be mapped.
' @returns {Boolean} True if the drive can be mapped.
'
Public Property Get IsAvailableForMapping() As Boolean
On Error GoTo Catch

    If Not (ValidatePropertyAssignments) Then
        Exit Property
    End If
    
    ' Prevent mapping of CD/DVD drive and RamDisk:
    If (GetDriveType(m_driveName) < DriveType.REMOTE) Then
        IsAvailableForMapping = (Len(GetConnectionDetails(1)) = 0)
    End If

Finally:
    Exit Property

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "IsAvailableForMapping"
    Resume Finally
    
End Property

'
' Returns the path and API return code that corresponds to the specified
'     drive name.
' @returns {Variant} Array with connection details.
' @property (0) {SystemErrorCode} Code returned by the API call.
' @property (1) {String} Path associated with the specified drive name.
'
Private Property Get GetConnectionDetails() As Variant
On Local Error GoTo Catch

    Dim remoteName As String
    remoteName = String$(255, Chr$(32))
    
    Dim returnCode As SystemErrorCode
    returnCode = WNetGetConnection(m_driveName, remoteName, Len(remoteName))
    
    Dim connectionDetails(1) As String
    connectionDetails(0) = returnCode
    
    ' If you don't Trim the remote name and the drive isn't mapped, it'll be
    ' 255 characters long:
    connectionDetails(1) = Trim$(Left$(remoteName, Len(remoteName)))
    
    GetConnectionDetails = connectionDetails

Finally:
    Exit Property

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "GetConnectionDetails"
    Resume Finally

End Property

Private Function ValidatePropertyAssignments( _
                 Optional ByVal isPathRequired As Boolean) As Boolean
On Error Resume Next
    
    Dim errorMessage As String
    If (m_driveName = "") Then
        MsgBox "You must specify a drive name.", vbExclamation, "Error"
        Exit Function
    End If
    
    If (isPathRequired) Then
        If (m_desiredPath = "") Then
            MsgBox "You must specify a desired path.", vbExclamation, "Error"
            Exit Function
        End If
    End If
    
    ValidatePropertyAssignments = True
    
End Function

'
' Evaluates all of the current drives that are mapped and returns each one
'     separated by a " ".
' @returns {String} List of mapped drives.
'
Private Property Get GetListOfMappedDrives() As String
On Error GoTo Catch

    Dim driveList As String * 255
    Dim lengthOfDriveList As Long
    lengthOfDriveList = Len(driveList)
    
    Dim logicalDriveStrings As Long
    logicalDriveStrings = GetLogicalDriveStrings(lengthOfDriveList, driveList)
    
    GetListOfMappedDrives = Left(driveList, logicalDriveStrings)

Finally:
    Exit Property

Catch:
    Debug.Print Err.Number, Err.Description, MODULE_NAME, _
                "GetListOfMappedDrives"
    Resume Finally

End Property

• Removed system error code handler for 2250 (instead of raising an error, it should continued attempting to map the drive).
• Added properties for specifying drive name and desired path (instead of using parameters).
• Added validation to ensure the drive name and desired path properties are specified.
• Fixed issue with confirmation prompt appearing if isSilent was set to True.