VBA – 无法将驱动器映射到另一台计算机上的共享点
我正在使用VBA映射到公司的共享点驱动器。 目的是将本地文件保存到共享点，并成功删除本地文件并取消映射驱动器。
在我的机器上（Windows 10 64位），代码工作正常，成功映射驱动器，创build文件夹和文件，成功上传到共享点并取消映射驱动器。
但是，当我在同事的计算机（Window 7）上运行包含相同代码的Excel工作簿时，它失败了。 没有显示任何错误，除了它不断加载和加载，直到Excel 不响应 。 我试图手动映射驱动器，它成功了。
我试图debugging，发现代码停止（继续加载）在MsgBox "Hello"但无法找出缺less的东西。
两者都使用Excel 2016
任何帮助和build议表示赞赏。 让我知道是否需要更多的信息。 提前致谢。
这是我的vba代码
Sub imgClicked() Dim fileName As String Dim SharePointLib As String Dim MyPath As String Dim folderPath As String Dim objNet As Object Dim copyPath As String Dim copyFilePath As String folderPath = Application.ThisWorkbook.path MyPath = Application.ThisWorkbook.FullName Dim objFSO As Object Dim strMappedDriveLetter As String Dim strPath As String Dim spPath As String strPath = "https://company.com/sites/test/test 123/" 'example path spPath = AvailableDriveLetter + ":\test.xlsm" 'example path copyPath = folderPath + "\copyPath\" 'Add reference if missing Call AddReference Set objFSO = CreateObject("Scripting.FileSystemObject") With objFSO strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath)) If Not Len(strMappedDriveLetter) > 0 Then strMappedDriveLetter = AvailableDriveLetter If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure" Exit Sub End If End If ' Check file/folder path If statement here End With Set objFSO = Nothing End Sub
代码获取驱动器
' Returns the available drive letter starting from Z Public Function AvailableDriveLetter() As String ' Returns the last available (unmapped) drive letter, working backwards from Z: Dim objFSO As Object Dim i As Long Set objFSO = CreateObject("Scripting.FileSystemObject") For i = Asc("Z") To Asc("A") Step -1 Select Case objFSO.DriveExists(Chr(i)) Case True Case False Select Case Chr(i) Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway... Case Else AvailableDriveLetter = Chr(i) Exit For End Select End Select Next i Set objFSO = Nothing MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive End Function
映射驱动器的function
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean Dim objNetwork As Object If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function Set objNetwork = CreateObject("WScript.Network") objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False MapDrive = True MsgBox "Successfully Created the Drive!" Set objNetwork = Nothing End Function
代码为MappedDrive
Public Function GetMappedDrives() As Variant ' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine Dim objFSO As Object Dim objDrive As Object Dim arrMappedDrives() As Variant Dim i As Long Set objFSO = CreateObject("Scripting.FileSystemObject") ReDim arrMappedDrives(1 To 2, 1 To 1) For i = Asc("A") To Asc("Z") If objFSO.DriveExists(Chr(i)) Then Set objDrive = objFSO.GetDrive(Chr(i)) If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1) End If arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter... arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName End If Next i GetMappedDrives = arrMappedDrives Set objDrive = Nothing Set objFSO = Nothing End Function Public Function IsAlreadyMapped(strPath As String) As String ' Tests if a given network path is already mapped on the users machine ' (Returns corresponding drive letter or ZLS if not found) Dim strMappedDrives() As Variant Dim i As Long strMappedDrives = GetMappedDrives For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2) If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then IsAlreadyMapped = strMappedDrives(1, i) Exit For End If Next i Set objNetwork = Nothing End Function
添加参考
Sub AddReference() 'Macro purpose: To add a reference to the project using the GUID for the 'reference library Dim strGUID As String, theRef As Variant, i As Long 'Update the GUID you need below. strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}" 'Set to continue in case of error On Error Resume Next 'Remove any missing references For i = ThisWorkbook.VBProject.References.Count To 1 Step -1 Set theRef = ThisWorkbook.VBProject.References.Item(i) If theRef.isbroken = True Then ThisWorkbook.VBProject.References.Remove theRef End If Next i 'Clear any errors so that error trapping for GUID additions can be evaluated Err.Clear 'Add the reference ThisWorkbook.VBProject.References.AddFromGuid _ GUID:=strGUID, Major:=1, Minor:=0 'If an error was encountered, inform the user Select Case Err.Number Case Is = 32813 'Reference already in use. No action necessary Case Is = vbNullString 'Reference added without issue Case Else 'An unknown error was encountered, so alert the user MsgBox "A problem was encountered trying to" & vbNewLine _ & "add or remove a reference in this file" & vbNewLine & "Please check the " _ & "references in your VBA project!", vbCritical + vbOKOnly, "Error!" End Select On Error GoTo 0 End Sub
过程imgClicked正在多次调用函数AvailableDriveLetter 。 请记住，每次引用该函数时都必须执行该函数。
我跑imgClicked （假设这是你开始的过程），我被告知， 两次 ， "Next available letter = Z"和"Hello" ，然后崩溃的Excel（可能陷入创buildFileSystem对象循环寻找一个可用的驱动器号？）
尝试在过程的开始处将AvailableDriveLetter分配给一个variables（string），并在每次需要该值时引用该variables，并查看是否仍然存在问题。
（记得在执行前保存 – 当解决“应用程序挂起”问题时，我感到沮丧，因为我一直忘记保存我的更改，然后在崩溃时丢失它们！）
如果这不起作用，请在“Hello”框后面的End Function行上添加一个断点（ F9 ），并查看代码是否停在那里。 （我很难相信MsgBox或End Function是罪魁祸首。）如果不是，那么在哪个过程之后运行？
还有一件事问题是否得到解决：
在你的模块的一开始添加
Option Explicit，然后Compile项目并修复你缺less的variables声明。无论何时解决问题，都build议使用这种方法来消除可能的声明问题。