Question

我已经狩猎了几个小时，还没有找到解决方案。我有2,000多个PDF文件的列表，这些文件可超链接到内部Sharepoint驱动器。我的目标是使用VBA或命令提示符创建PDF的本地副本，但到目前为止，我还没有遇到一个被证明富有成效的序列。

是否可以仅通过HTTP地址列表来呈现PDF？
可以使用VBA完成吗？
如果可以，怎么办？

感谢您的阅读。

Answer 1

我假设您在Sheet1的A列中有2000+个链接的列表。下面的代码还将标记PDF文件是否存在（URL验证）并将其记录在相邻的B列中。

此外，如果内部网站（共享点）需要强制登录/密码，则可能需要修改此代码。

Option Explicit

Sub Download_PDF()
    Dim i As Long
    Dim FileNum As Long
    Dim FileData() As Byte
    Dim MyFile As String
    Dim wHttp As Object
    Dim TempFile As String
    Dim strDownloadDirectory As String
    Dim rngSource As Range
    Dim rng As Range

    On Error Resume Next
        Set wHttp = CreateObject("WinHTTP.WinHTTPrequest.5")
        If Err.Number <> 0 Then
            Set wHttp = CreateObject("WinHTTP.WinHTTPrequest.5.1")
        End If
    On Error GoTo 0

    On Error Resume Next
    'Provide destination directory
    strDownloadDirectory = "C:\MyDownloads"
    'Provide source range of list of hyperlinks
    Set rngSource = Worksheets("Sheet1").Range("A2:A" & Worksheets("Sheet1").Range("A" & Application.Rows.Count).End(xlUp).Row)

    'If Download Directory (Destination) doesn't exist then create it.
    If Dir(strDownloadDirectory, vbDirectory) = Empty Then MkDir strDownloadDirectory

    'If there is no url then no point in continuing
    If rngSource.Cells.Count <= 0 Then Exit Sub

    For Each rng In rngSource.Cells
        MyFile = rng.Text
        If CheckURL(MyFile) Then
            FileNum = FreeFile
            rng.Offset(0, 1).Value = "Downloading ..."
            TempFile = Right(MyFile, InStr(1, StrReverse(MyFile), "/") - 1)
            wHttp.Open "GET", MyFile, False
            wHttp.Send
            FileData = wHttp.ResponseBody
            FileNum = FreeFile
            Open "C:\MyDownloads\" & TempFile For Binary Access Write As #FileNum
                Put #FileNum, 1, FileData
            Close #FileNum
            If Err.Number <> 0 Then
                rng.Offset(0, 1).Value = "Error while Downloading : " & Err.Description
                Err.Clear
            Else
                rng.Offset(0, 1).Value = "Download Successful!"
            End If
        Else
            rng.Offset(0, 1).Value = "File not found !!"
            Err.Clear
        End If
    Next
    Set wHttp = Nothing
    MsgBox "Open the folder [ " & strDownloadDirectory & " ] for the downloaded files..."
End Sub

'Validate the given URL (Hyperlinks)
Function CheckURL(URL) As Boolean
    Dim wHttp As Object
    On Error Resume Next
        Set wHttp = CreateObject("winhttp.winhttprequest.5")
        If Err.Number <> 0 Then
            Set wHttp = CreateObject("winhttp.winhttprequest.5.1")
        End If
    On Error GoTo 0

    On Error Resume Next
    wHttp.Open "HEAD", URL, False
    wHttp.Send
    If wHttp.Status = 200 Then
        CheckURL = True
    Else
        CheckURL = False
    End If
End Function

从Excel单元格中的地址创建PDF

1 个答案: