Создать PDF с адреса в ячейке Excel - PullRequest
Новая
       27

Создать PDF с адреса в ячейке Excel

0 голосов
/ 20 сентября 2018

Я часами охотился и пока не нашел решения.У меня есть список из более чем 2000 PDF-файлов с гиперссылкой на внутренний накопитель Sharepoint.Моя цель - создать локальную копию PDF-файлов либо с помощью VBA, либо с помощью командной строки, но до сих пор я не сталкивался с последовательностью, которая оказалась плодотворной.

Можно ли визуализировать PDF-файлы просто из спискаhttp адреса?
Можно ли это сделать с помощью VBA?
Если да, то как?

Заранее спасибо за чтение.

1 Ответ

0 голосов
/ 20 сентября 2018

Я предполагаю, что у вас есть список из 2000+ ссылок в столбце А Листа1.Приведенный ниже код также помечает, существует ли файл PDF или нет (проверка URL), и записывает его в соседний столбец B.

Кроме того, если внутренний веб-сайт (sharepoint) требует принудительного входа в систему / пароль, тогда этот код может потребоватьсямодификации. 

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
...