vba - 将网页另存为 PDF 到某个目录

Question

我有它，它将打开 Internet Explorer 给用户另存为框，然后退出。但是，我希望用户不必导航到正确的文件夹，而是该目录来自工作表中的一个单元格并将网页保存为 PDF。我已经安装了完整的 Adob​​e。编码:

 Sub WebSMacro()
        Dim IE As Object
        Dim Webloc As String
        Dim FullWeb As String
        Webloc = ActiveSheet.Range("B39").Value
        FullWeb = "http://www.example.com=" & Webloc
        Set IE = CreateObject("InternetExplorer.Application")
        IE.Visible = True
        IE.Navigate FullWeb
        Do While IE.Busy
            Application.Wait DateAdd("s", 1, Now)
        Loop


        IE.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
        Application.Wait DateAdd("s", 10, Now)
        IE.Quit
        Set IE = Nothing

    End Sub

Answer 1

今天，你赢了互联网!

由于我想为了个人利益更深入地了解这一点，所以我使用了 2nd link 中的代码。我在评论中引用了代码以按照您定义的方式工作。

代码将在 SaveAs 对话框中输入 FilePath 和 Name(从单元格中收集)并将其保存到输入的位置。

这是主要的子(带评论):

Sub WebSMacro()

'set default printer to AdobePDF
Dim WSHNetwork As Object
Set WSHNetwork = CreateObject("WScript.Network")
WSHNetwork.SetDefaultPrinter "Adobe PDF"

'get pdfSave as Path from cell range
Dim sFolder As String
sFolder = Sheets("Sheet1").Range("A1") 'assumes folder save as path is in cell A1 of mySheets

Dim IE As Object
Dim Webloc As String
Dim FullWeb As String

Webloc = ActiveSheet.Range("B39").Value
FullWeb = "http://www.example.com" & Webloc

Set IE = CreateObject("InternetExplorer.Application")

With IE

    .Visible = True
    .Navigate FullWeb

    Do While .Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop

    .ExecWB 6, 2 'OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
    Application.Wait DateAdd("s", 3, Now)
    Call PDFPrint(sFolder & Webloc & ".pdf")

    .Quit

End With

Set IE = Nothing

End Sub

您还需要将这两个子放在工作簿中的某个位置(可以是与主子相同的模块(或不同的模块)):

Sub PDFPrint(strPDFPath As String)

    'Prints a web page as PDF file using Adobe Professional.
    'API functions are used to specify the necessary windows while
    'a WMI function is used to check printer's status.

    'By Christos Samaras
    'http://www.myengineeringworld.net

    Dim Ret                 As Long
    Dim ChildRet            As Long
    Dim ChildRet2           As Long
    Dim ChildRet3           As Long
    Dim comboRet            As Long
    Dim editRet             As Long
    Dim ChildSaveButton     As Long
    Dim PDFRet              As Long
    Dim PDFName             As String
    Dim StartTime           As Date

    'Find the main print window.
    StartTime = Now()
    Do Until Now() > StartTime + TimeValue("00:00:05")
        Ret = 0
        DoEvents
        Ret = FindWindow(vbNullString, "Save PDF File As")
        If Ret <> 0 Then Exit Do
    Loop

    If Ret <> 0 Then
        SetForegroundWindow (Ret)
        'Find the first child window.
        StartTime = Now()
        Do Until Now() > StartTime + TimeValue("00:00:05")
            ChildRet = 0
            DoEvents
            ChildRet = FindWindowEx(Ret, ByVal 0&, "DUIViewWndClassName", vbNullString)
            If ChildRet <> 0 Then Exit Do
        Loop

        If ChildRet <> 0 Then
            'Find the second child window.
            StartTime = Now()
            Do Until Now() > StartTime + TimeValue("00:00:05")
                ChildRet2 = 0
                DoEvents
                ChildRet2 = FindWindowEx(ChildRet, ByVal 0&, "DirectUIHWND", vbNullString)
                If ChildRet2 <> 0 Then Exit Do
            Loop

            If ChildRet2 <> 0 Then
                'Find the third child window.
                StartTime = Now()
                Do Until Now() > StartTime + TimeValue("00:00:05")
                    ChildRet3 = 0
                    DoEvents
                    ChildRet3 = FindWindowEx(ChildRet2, ByVal 0&, "FloatNotifySink", vbNullString)
                    If ChildRet3 <> 0 Then Exit Do
                Loop

                If ChildRet3 <> 0 Then
                    'Find the combobox that will be edited.
                    StartTime = Now()
                    Do Until Now() > StartTime + TimeValue("00:00:05")
                        comboRet = 0
                        DoEvents
                        comboRet = FindWindowEx(ChildRet3, ByVal 0&, "ComboBox", vbNullString)
                        If comboRet <> 0 Then Exit Do
                    Loop

                    If comboRet <> 0 Then
                        'Finally, find the "edit property" of the combobox.
                        StartTime = Now()
                        Do Until Now() > StartTime + TimeValue("00:00:05")
                            editRet = 0
                            DoEvents
                            editRet = FindWindowEx(comboRet, ByVal 0&, "Edit", vbNullString)
                            If editRet <> 0 Then Exit Do
                        Loop

                        'Add the PDF path to the file name combobox of the print window.
                        If editRet <> 0 Then
                            SendMessage editRet, WM_SETTEXT, 0&, ByVal " " & strPDFPath
                            keybd_event VK_DELETE, 0, 0, 0 'press delete
                            keybd_event VK_DELETE, 0, KEYEVENTF_KEYUP, 0 ' release delete

                            'Get the PDF file name from the full path.
                            On Error Resume Next
                            PDFName = Mid(strPDFPath, WorksheetFunction.Find("*", WorksheetFunction.Substitute(strPDFPath, "\", "*", Len(strPDFPath) _
                            - Len(WorksheetFunction.Substitute(strPDFPath, "\", "")))) + 1, Len(strPDFPath))
                            On Error GoTo 0

                            'Save/print the web page by pressing the save button of the print window.
                            Sleep 1000
                            ChildSaveButton = FindWindowEx(Ret, ByVal 0&, "Button", "&Save")
                            SendMessage ChildSaveButton, BM_CLICK, 0, 0

                            'Sometimes the printing delays, especially in large colorful web pages.
                            'Here the code checks printer status and if is idle it means that the
                            'printing has finished.
                            Do Until CheckPrinterStatus("Adobe PDF") = "Idle"
                                DoEvents
                                If CheckPrinterStatus("Adobe PDF") = "Error" Then Exit Do
                            Loop

                            'Since the Adobe Professional opens after finishing the printing, find
                            'the open PDF document and close it (using a post message).
                            StartTime = Now()
                            Do Until StartTime > StartTime + TimeValue("00:00:05")
                                PDFRet = 0
                                DoEvents
                                PDFRet = FindWindow(vbNullString, PDFName & " - Adobe Acrobat")
                                If PDFRet <> 0 Then Exit Do
                            Loop
                            If PDFRet <> 0 Then
                                PostMessage PDFRet, WM_CLOSE, 0&, 0&
                            End If
                        End If
                    End If
                End If
            End If
        End If
   End If
End Sub

Function CheckPrinterStatus(strPrinterName As String) As String

    'Provided the printer name the functions returns a string
    'with the printer status.

    'By Christos Samaras
    'http://www.myengineeringworld.net

    Dim strComputer As String
    Dim objWMIService As Object
    Dim colInstalledPrinters As Variant
    Dim objPrinter As Object

    'Set the WMI object and the check the install printers.
    On Error Resume Next
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")

    'If an error occurs in the previous step, the function will return error.
    If Err.Number <> 0 Then
        CheckPrinterStatus = "Error"
    End If
    On Error GoTo 0

    'The function loops through all installed printers and for the selected printer,
    'checks it status.
    For Each objPrinter In colInstalledPrinters
        If objPrinter.Name = strPrinterName Then
            Select Case objPrinter.PrinterStatus
                Case 1: CheckPrinterStatus = "Other"
                Case 2: CheckPrinterStatus = "Unknown"
                Case 3: CheckPrinterStatus = "Idle"
                Case 4: CheckPrinterStatus = "Printing"
                Case 5: CheckPrinterStatus = "Warmup"
                Case 6: CheckPrinterStatus = "Stopped printing"
                Case 7: CheckPrinterStatus = "Offline"
                Case Else: CheckPrinterStatus = "Error"
            End Select
        End If
    Next objPrinter

    'If there is a blank status the function returns error.
    If CheckPrinterStatus = "" Then CheckPrinterStatus = "Error"

End Function

最后在一个模块中声明这些常量和函数(可以是与主子相同的模块(或不同的模块)。

Option Explicit

Public Declare Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
    (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Public Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hWnd As Long) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Sub keybd_event Lib "user32" _
    (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


'Constants used in API functions.
Public Const SW_MAXIMIZE = 3
Public Const WM_SETTEXT = &HC
Public Const VK_DELETE = &H2E
Public Const KEYEVENTF_KEYUP = &H2
Public Const BM_CLICK = &HF5&
Public Const WM_CLOSE As Long = &H10