Converting DOS Batch file commands to VBA Function

Question

I have created and am using the following function to map and shorten the path-length of a network drive using SUBST command to work with my tool that implements ADO.

Function MapBasePathToDrive(FullDirectory As String, strDrive As String, blnReadAttr As Boolean) As String

    Dim objShell As Object
    Dim sCmd$
    Dim WaitOnReturn As Boolean: WaitOnReturn = True
    Dim WindowStyle As Integer: WindowStyle = 0
    Dim i&, lngErr&

    ' remove backslash for `SUBST` dos command to work
    If Right(FullDirectory, 1) = "\" Then FullDirectory = Left(FullDirectory, Len(FullDirectory) - 1)

    ' prefix & suffix directory with double-quotes
    FullDirectory = Chr(34) & FullDirectory & Chr(34)

    Set objShell = CreateObject("WScript.Shell")
    For i = 1 To 2
        If i = 1 Then
            'remove drive
            sCmd = "SUBST" & " " & strDrive & " " & "/D"
            lngErr = objShell.Run(sCmd, WindowStyle, WaitOnReturn)
        Else
            'add drive
            sCmd = "SUBST" & " " & strDrive
            lngErr = objShell.Run(sCmd & " " & FullDirectory, WindowStyle, WaitOnReturn)
        End If
    Next i

    ' remove read-only attribute from Destination folder if you plan to copy files
    If blnReadAttr Then
        sCmd = "ATTRIB " & "-R" & " " & strDrive & "\*.*" & " " & "/S /D"
        lngErr = objShell.Run(sCmd, WindowStyle, WaitOnReturn)
    End If

    ' to refresh explorer to show newly created drive
    sCmd = "%windir%\explorer.exe /n,"
    lngErr = objShell.Run(sCmd & strDrive, WindowStyle, WaitOnReturn)

    ' add backslash to drive if absent
    MapBasePathToDrive = PathWithBackSlashes(strDrive)

End Function

The above function works well most of the time to shorten the long network path and then passing it to Application.FileDialog.InitialFilename. However, if a drive (say Y:) is already mapped, then the problem ensues as Application.FileDialog.InitialFilename goes for a toss and end user is not able to select the required files, but sees files of Y:\!

What i want to do :

• See if the concerned Drive e.g. Y: is available or not.
• If in use, assign Y:'s network path to the next freely available drive.
• Disconnect (delete) Y:
• Assign Y: to concerned Directory.

I have the below batch file that does exactly that, but i don't know how to convert this batch code into a VBA function i.e. similar to above shown function. Any help would be most appreciated.

@echo off 
if exist y:\ (
    for /F "tokens=1,2,3" %%G in ('net use^|Find /I "Y:"^|Find "\\"')  do ( net use * %%H >nul 2>&1)
    net use y: /delete >nul 2>&1
)
net use y: \\xx.xx.xx.xx\SomeFolder >nul 2>&1

EDIT:

I modified the above Function to add this code. The problem lies only with the sCMD string that is not getting executed by WScript.Shell because of incorrect double-quotes.

• Can someone help me with the proper syntax?
• If it is a local folder i need to map, how would the syntax change?

...

Sub TestDriveMapping()
    MapBasePathToDrive "\\xx.xx.xx.xx\SomeFolder", "Y:", True
End Sub

Function MapBasePathToDrive(FullDirectory As String, strDrive As String, blnReadAttr As Boolean) As String

    Dim objShell As Object
    Dim sCmd$
    Dim WaitOnReturn As Boolean: WaitOnReturn = True
    Dim WindowStyle As Integer: WindowStyle = 0
    Dim i&, lngErr&

    ' remove backslash for `NET USE` dos command to work
    If Right(FullDirectory, 1) = "\" Then FullDirectory = Left(FullDirectory, Len(FullDirectory) - 1)

    ' prefix & suffix directory with double-quotes
    FullDirectory = Chr(34) & FullDirectory & Chr(34)

    Set objShell = CreateObject("WScript.Shell")
    sCmd = ""
    sCmd = "@Echo Off " & vbCrLf
    sCmd = sCmd & " IF EXIST " & strDrive & " (" & vbCrLf
    sCmd = sCmd & "  FOR /F " & Chr(34) & "TOKENS=1,2,3" & Chr(34) & " %G IN (" & Chr(39) & "NET USE ^|Find /I " & Chr(34) & strDrive & Chr(34) & "^|Find ""\\""" & Chr(39) & ")  DO ( NET USE * %H >NUL 2>&1)" & vbCrLf
    sCmd = sCmd & "  NET USE " & strDrive & " /DELETE >NUL 2>&1" & vbCrLf
    sCmd = sCmd & " )" & vbCrLf
    sCmd = sCmd & " NET USE " & strDrive & " " & FullDirectory & " >NUL 2>&1"

    lngErr = objShell.Run(sCmd, WindowStyle, WaitOnReturn)

    ' remove read-only attribute from Destination folder if you plan to copy files
    If blnReadAttr Then
        sCmd = "ATTRIB " & "-R" & " " & strDrive & "\*.*" & " " & "/S /D"
        lngErr = objShell.Run(sCmd, WindowStyle, WaitOnReturn)
    End If

    ' to refresh explorer to show newly created drive
    sCmd = "%windir%\explorer.exe /n,"
    lngErr = objShell.Run(sCmd & strDrive, WindowStyle, WaitOnReturn)

    ' add backslash to drive if absent
    MapBasePathToDrive = PathWithBackSlashes(strDrive)

End Function

Answer 1

Try the next code, please. It uses VBScript objects for checking and doing the mapping...

Sub ReMapDrive()
  Dim objNet As Object, strLocal As String, strPath As String, fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objNet = CreateObject("WScript.Network")
  'Name the drive and its path:
  strLocal = "Y:"
  strPath = "\\xx.xx.xx.xx\SomeFolder"

    'Check if it is mapped and map it if it is not:
    If fso.FolderExists(strLocal) = True Then
        MsgBox (strLocal & " Mapped")
    Else
        objNet.MapNetworkDrive strLocal, , False
        MsgBox (strLocal & " Re-mapped")
    End If
   Set fso = Nothing: Set objNet = Nothing
End Sub

I am not the father of the code. I have it from the internet (not knowing its provenience) and I use it for years... I just adapted it in a way to work (I hope) in your case.

The next function will return (in an array) your mapped drives and their path. I also included a sub to see how it can be tested/used...

Sub testEnumMPapp()
 Dim arrMap As Variant, i As Long
  arrMap = enumMappedDrives
  For i = 0 To UBound(arrMap, 2)
    Debug.Print arrMap(0, i), arrMap(1, i)
  Next i
End Sub

    Private Function enumMappedDrives() As Variant
      Dim objNet As Object, fso As Object, oDrives As Object
      Dim mapRep As Variant, i As Long, k As Long
      ReDim mapRep(1, 100)
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set objNet = CreateObject("WScript.Network")
      Set oDrives = objNet.EnumNetworkDrives
        If oDrives.Count > 0 Then
            For i = 0 To oDrives.Count - 1 Step 2
                mapRep(0, k) = oDrives.Item(i)
                mapRep(1, k) = oDrives.Item(i + 1)
                k = k + 1
            Next
        End If
        ReDim Preserve mapRep(1, k - 1)
        enumMappedDrives = mapRep
    End Function