mikerourke
12/1/2016 - 8:50 PM
Network Drive Mapping in VBA
Used to perform mapping functions in Access or Excel VBA for network drives.
' 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