VBA从Excel工作簿打印网页到PDF？

我有一个Excel工作簿，下面的代码。 它旨在导航到google.co.uk并以PDF格式打印网页。

这工作几乎没有问题。 代码导航到wepbage并打印到PDF并打开PDF文档。

但是，我似乎有问题设置我想要文件保存的位置。

我希望我的PDF文件始终保存在这个位置：

G:\QUALITY ASSURANCE\06_SUPPLIER INFORMATION 

但由于某种原因，它总是保存到桌面上。 应该有一个保存为打开的对话框，但它永远不会显示。

我已经从一个网站复制这个代码来尝试让我开始，所以我不假装理解所有这一切。 我对VBA很新。

本质上我的目标是让网页自动打印到PDF并保存在正确的文件夹中，而不需要用户提示保存对话框或不必保存。

保存后，我也不希望PDF打开。

这是我的代码。 我怎样才能让我的代码做我需要的？

码

 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 Sub WebSMacro() Application.DisplayAlerts = False Application.ScreenUpdating = False 'set default printer to AdobePDF Dim WSHNetwork As Object Dim dteStartTime As Date 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 FullWeb = "https://www.google.com" 'Set IE = CreateObject("InternetExplorer.Application") Set IE = New InternetExplorerMedium 'IE.Visible = True IE.navigate FullWeb dteStartTime = Now Do While IE.READYSTATE <> READYSTATE_COMPLETE If DateDiff("s", dteStartTime, Now) > 240 Then Exit Sub Loop IE.ExecWB 6, 2 'OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER Application.Wait DateAdd("s", 1, Now) Call PDFPrint2(Range("B" & ActiveCell.Row).Value & "_BRC_" & Replace(Range("K" & ActiveCell.Row).Value, "/", ".") & "_" & ".pdf") IE.Quit Set IE = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Sub PDFPrint2(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 Dim AcroApp 'open Acrobat and minimize Set AcroApp = CreateObject("AcroExch.App") strPDFPath = "G:\QUALITY ASSURANCE\06_SUPPLIER INFORMATION\" 'Find the main print window. StartTime = Now() Do Until Now() > StartTime + TimeValue("00:00:00") 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:00") 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:00") 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:00") 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:00") 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:00") 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 = "test" On Error GoTo 0 'Save/print the web page by pressing the save button of the print window. Sleep 0 ChildSaveButton = FindWindowEx(Ret, ByVal 0&, "Button", "&Save") SendMessage ChildSaveButton, BM_CLICK, 0, 0 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