Question

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

如果我允许脚本选择特定的映射，只有在我使用定义\ collaboration.company.corp@SSL \ DavWWWRoot \ collrooms \ specificfolder

时才会识别它。

如何在VBA中创建映射以告知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

和下载宏的其他部分是

'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上找到的脚本，但它不起作用

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

    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

问题还在于是否删除了处理方法＆＃34; Class_Terminate＆＃34;哪个unmaps驱动器会有帮助？当课程超出范围时，驱动器将被取消映射。我怎么能把它们放在一起。

将https映射到\\路径以进行下载的VBA脚本

0 个答案: