0

我已经创建并正在使用以下函数来映射和缩短网络驱动器的路径长度，使用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:\!

我想做的事 ：

  • 查看相关 Drive egY:是否可用。
  • 如果正在使用，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
4

1 回答 1

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 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
于 2020-03-02T12:09:12.207 回答