将https映射到\\path进行下载的VBA脚本

我写了一个脚本来使用VBA下载文件。 VBA脚本必须下载以https：//collaboration.company.corp/collrooms/specificfolder或\ collaboration.company.corp@SSL \ DavWWWRoot \ collrooms \ specificfolder开头的项目。具体文件夹是相同的。

如果我允许脚本select特定映射，则只有在使用定义\ collaboration.company.corp@SSL \ DavWWWRoot \ collrooms \ specific文件夹时才会识别该映射

如何在VBA中创build映射以告知Excel： https：//collaboration.company.corp/collrooms/specificfolder和\ collaboration.company.corp@SSL \ DavWWWRoot \ collrooms \ specificfolder是相同的，并且第一个规范也是有效？

我的代码：

Option Explicit Sub FolderSelection() 'Shows the folder picker dialog in order the user to select the folder 'in which the downloaded files will be saved. Dim FoldersPath As String 'Show the folder picker dialog. With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Select a folder to save your files..." .Show If .SelectedItems.Count = 0 Then Sheets("Main").Range("B4") = "-" MsgBox "You did't select a folder!", vbExclamation, "Canceled" Exit Sub Else FoldersPath = .SelectedItems(1) End If End With 'Pass the folder's path to the cell. HERE I AM MISSING THE MAPPING. It will show files starting with https if selected and not transfer it to the other structure. Sheets("Main").Range("B4") = FoldersPath End Sub Sub Clear() 'Clears the URLs, the result column and the folder's path. Dim LastRow As Long 'Find the last row. With Sheets("Main") .Activate LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row End With 'Clear the ranges. If LastRow > 7 Then With Sheets("Main") .Range("C8:D" & LastRow).ClearContents .Range("B4:D4").ClearContents .Range("B4").Select End With End If End Sub 

而下载macros的另一部分是

 'Check if the folder exists. I did not check whether it will also download with the https structure? DownloadFolder = sh.Range("B4") On Error Resume Next If Dir(DownloadFolder, vbDirectory) = vbNullString Then MsgBox "The path is incorrect!", vbCritical, "Folder's Path Error" sh.Range("B4").Select Exit Sub End If On Error GoTo 0 

我尝试了一个在Stackoverflow上find的脚本，但它不起作用

我创build了一个额外的模块：

  Sub test() Dim dm As New DriveMapper Dim sharepointFolder As Scripting.Folder Set sharepointFolder = dm.MapDrive("https://collaboration.company.corp/collrooms/") ' unsure whether I have to add something here and whether this will work with https Debug.Print sharepointFolder.Path End Sub 

并添加了下面的WebDAV映射作为一个新的CLASS

 Option Explicit Private oMappedDrive As Scripting.Drive Private oFSO As New Scripting.FileSystemObject Private oNetwork As New WshNetwork Private Sub Class_Terminate() UnmapDrive End Sub Public Function MapDrive(NetworkPath As String) As Scripting.Folder Dim DriveLetter As String, i As Integer UnmapDrive For i = Asc("Z") To Asc("A") Step -1 DriveLetter = Chr(i) If Not oFSO.DriveExists(DriveLetter) Then oNetwork.MapNetworkDrive DriveLetter & ":", NetworkPath Set oMappedDrive = oFSO.GetDrive(DriveLetter) Set MapDrive = oMappedDrive.RootFolder Exit For End If Next i End Function Private Sub UnmapDrive() If Not oMappedDrive Is Nothing Then If oMappedDrive.IsReady Then oNetwork.RemoveNetworkDrive oMappedDrive.DriveLetter & ":" End If Set oMappedDrive = Nothing End If End Sub 

问题是移除驱动器的映射的处理方法“Class_Terminate”是否会有所帮助？ 当class级超出范围，然后驱动器得到的未映射。 而我怎么能把它放在一起。