VBA-无法将驱动器映射到另一台计算机上的SharePoint

Question

我使用VBA映射到公司的SharePoint驱动器。目的是将本地文件保存到SharePoint，并在成功后删除本地文件并取消驱动器。

在我的计算机上（Windows 10 64bits），该代码正常工作，成功地映射了驱动器，创建的文件夹和文件，成功上传到SharePoint并取消驱动器。

但是，当我运行同事计算机上包含相同代码的同一Excel工作簿（窗口7）时，它会失败。没有显示错误，除非它继续加载和加载，直到excel 不响应。我尝试手动映射驱动器，成功。

我试图调试，发现代码停止（不断加载）在MsgBox "Hello"处，但无法弄清楚丢失的内容。

两者都使用Excel 2016

任何帮助和建议将受到赞赏。让我知道是否需要更多信息。预先感谢。

这是我的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

函数映射驱动器

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

Answer 1

过程 imgClicked多次调用 AvailableDriveLetter。请记住，该功能每次参考时都必须执行。

i运行 imgClicked（假设这是您开始的过程），我被告知，两次， "Next available letter = Z" and "Hello"，然后它崩溃了excel（也许被卡在创建文件系统对象的循环中对于可用的驱动字母？）

尝试在过程的开头将AvailableDriveLetter分配给变量（字符串），并在每次需要该值时参考变量，并查看是否仍然存在问题。

（请记住要在执行前保存 - 在"挂起挂断"问题时，我会感到沮丧，因为我一直忘记保存更改，然后在崩溃时丢失它们！）

）

如果这不起作用，请在您的 End Function行上添加一个断点（ f9 ）。盒子，看看代码是否停在那里。（我很难相信MsgBox或End Function是罪魁祸首。）如果没有，则在此之后运行了哪个过程？

是否解决问题是否解决：

在模块的开始时添加Option Explicit，然后Compile项目并修复您的缺失变量声明。

每当将问题作为消除可变声明问题作为可能原因的手段时，建议这样做。