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

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

在我的计算机上（Windows 10 64位），代码运行正常，可以成功映射驱动器，创建文件夹和文件，成功上传到共享点并取消映射驱动器。

但是，当我在同事的计算机（Window 7）上运行包含相同代码的相同excel工作簿时，它失败了。没有显示任何错误，除了它一直加载并加载直到Excel Not Responsive为止。我尝试手动映射驱动器，它成功。

我尝试调试，发现该代码在（停止加载时保持）停止运行，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