Преобразование команд пакетного файла DOS в функцию VBA

Question

Я создал и использую следующую функцию для сопоставления и сокращения длины пути сетевого диска с помощью команды SUBST для работы с моим инструментом, реализующим 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

Вышеуказанная функция хорошо работает большую часть времени, сокращая длинный сетевой путь, а затем передавая его на Application.FileDialog.InitialFilename. Однако, если диск (скажем, Y :) уже подключен, возникает проблема, поскольку Application.FileDialog.InitialFilename идет на бросок, и конечный пользователь не может выбрать требуемые файлы, но видит файлы Y:\!

Что я хочу сделать:

• Проверьте, доступен ли соответствующий диск, например, Y: или нет.
• Если используется, назначьте сетевой путь Y: для следующий свободно доступный диск.
• Отключение (удаление) Y:
• Назначение Y: для соответствующего каталога.

У меня есть приведенный ниже пакетный файл, который выполняет именно так, но я не знаю, как преобразовать этот пакетный код в функцию VBA, то есть аналогичную показанной выше функции. Любая помощь будет наиболее ценной.

@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

РЕДАКТИРОВАТЬ:

Я изменил вышеупомянутую функцию, чтобы добавить этот код. Проблема заключается только в строке sCMD, которая не выполняется WScript.Shell из-за неправильных двойных кавычек.

• Может ли кто-нибудь помочь мне с правильным синтаксисом?
• Если это локальная папка, которую мне нужно сопоставить, как изменится синтаксис?

...

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

Попробуйте следующий код, пожалуйста. Он использует объекты VBScript для проверки и отображения ...

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

Я не являюсь отцом кода. У меня он есть из inte rnet (не зная его происхождения), и я использую его годами ... Я просто адаптировал его так, чтобы он работал (надеюсь) в вашем случае.

Следующая функция вернет (в массиве) ваши подключенные диски и их путь. Я также включил саб, чтобы увидеть, как его можно протестировать / использовать ...

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