Сохранение веб-страницы в формате PDF в определенном каталоге

Question

У меня есть он, где он откроется Internet Explorer, предоставит пользователю сохранить как поле, а затем выйти. Однако я бы предпочел, чтобы вместо того, чтобы пользователь переходил к правильной папке, каталог поступает из ячейки на листе и сохраняет веб-страницу в виде PDF-файла. У меня установлен Adobe. Код:

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, на который я ссылался в своем комментарии, чтобы заставить код работать так, как вы его определили.

Код войдет в FilePath и Name (собранный из ячейки) в диалоговое окно SaveAs и сохранит его в указанное место.

Вот главная суб (с комментариями):

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 

.