将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*" %%G in ('net use^|Find "\\"^|Find /I "y:"')  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

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 enumMappedDrive()
  Dim objNet As Object, fso As Object, oDrives As Object, mapRep As String, i As Long
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objNet = CreateObject("WScript.Network")
  Set oDrives = objNet.EnumNetworkDrives
    If oDrives.Count > 0 Then
        mapRep = mapRep & "Mapped Drive Information: " & vbCrLf
        For i = 0 To oDrives.Count - 1 Step 2
            mapRep = mapRep & "Drive " & oDrives.Item(i) & _
                            " = " & oDrives.Item(i + 1) & vbCrLf
        Next
    End If
    Debug.Print mapRep
End Sub

[当我有空的时候，我将尝试混合使用这两个代码，或者找到一种直接检索最后一个空字母驱动器的方法，即使我不确定这样做是否容易...