Question

我需要从网页下载所有PDF并将其保存到文件夹中。网页上的PDF通过不同的链接下载。以下是PDF所在的网页：NRCS工程手册和手册| NRCS北达科他州。我已经创建了文件夹位置，如下所示：

Function FileFolderExists(strFullPath As String) As Boolean
'Macro Purpose: Check if a folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
On Error GoTo 0
End Function

'Creates file folder for saving imported precipitation data
'Used as Micro for "Make Destination Folder" Button

Sub Make_Folder()
Dim objFSO As Object
Dim objFolder As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")

 'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder(CurDir())

Range("u11").Select
Selection.ClearContents

' Opens windows explorer for creation of folder to save .pdf files
If Len(Dir(CurDir() & "\Stockwater PDFs", vbDirectory)) = 0 Then MkDir(CurDir() & "\Stockwater PDFs")

If FileFolderExists(CurDir() & "\Stockwater PDFs") Then
    MsgBox "Folder Created Sucessfully!!!"
Else
    MsgBox "Folder does not exist!"
End If

If FileFolderExists(CurDir() & "\Stockwater PDFs") Then
ActiveSheet.Range("u11").Value = "Stockwater PDFs folder made in the " & objFolder.Name
End If

End Sub

一旦从网站下载文件（我需要帮助的下面代码的第一部分），我会列出他们保存到的文件夹中的文件（我已经存在）：

Sub GetWebPageDocs()

' Erases all listed files shown to be located in the CurDir()\Stockwater PDFs folder

Range("n17:n50").Select
Selection.ClearContents
Range("n16").Select

' Lists current files located in the CurDir()\Stockwater PDFs folder

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")

 'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder(CurDir() & "\Stockwater PDFs")
irow = 17
icolumn = 14
ActiveSheet.Range("N16").Value = "The files found in the " & objFolder.Name & " folder are:"

 'Loop through the Files collection
For Each objFile In objFolder.Files
    ActiveSheet.Cells(irow, icolumn).Value = objFile.Name
    irow = irow + 1
    icolumn = icolumn

Next

 'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing

End Sub

如果将所有想要的PDF放在位于网站上的单个链接的ZIP文件中会更容易，那么这可能是最佳选择。

提前感谢您的帮助。

我尝试过以下操作，但在Dim xHTTP上收到编译错误，因为MSXML2.XMLHTTP

Dim sUrl As String
Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument
Dim hAnchor As MSHTML.HTMLAnchorElement
Dim Ret As Long
Dim sPath As String
Dim i As Long

sPath = CurDir() & "\Stockwater PDFs"
sUrl = "http://www.nrcs.usda.gov/wps/portal/nrcs/detail/nd/technical/engineering/?cid=stelprdb1269591"

'Get the directory listing
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", sUrl
xHttp.send

'Wait for the page to load
Do Until xHttp.readyState = 4
    DoEvents
Loop

'Put the page in an HTML document
Set hDoc = New MSHTML.HTMLDocument
hDoc.body.innerHTML = xHttp.responseText

'Loop through the hyperlinks on the directory listing
For i = 0 To hDoc.getElementsByTagName("a").Length - 1
    Set hAnchor = hDoc.getElementsByTagName("a").Item(i)

    'test the pathname to see if it matches your pattern
    If hAnchor.pathname Like "*.pdf" Then
        Ret = URLDownloadToFile(0, sUrl & hAnchor.pathname, sPath & hAnchor.pathname, 0, 0)
        If Ret = 0 Then
            Debug.Print sUrl & hAnchor.pathname & " downloaded to " & sPath
        Else
            Debug.Print sUrl & hAnchor.pathname & " not downloaded"
        End If
    End If
Next i

Excel中的VBA可从网页下载所有PDF

0 个答案: