将 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

我不是代码之父。我从互联网上获得它（不知道它的出处）并且我使用它多年......我只是将它调整为适合你的工作方式（我希望）。

下一个函数将返回（在一个数组中）您映射的驱动器及其路径。我还包括了一个 sub 来看看它是如何被测试/使用的......

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