我已经创建并正在使用以下功能,使用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
请尝试下一个代码。它使用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
[当我有空的时候,我将尝试混合使用这两个代码,或者找到一种直接检索最后一个空字母驱动器的方法,即使我不确定这样做是否容易...