将网页保存为PDF到某个目录 [英] Saving webpage as PDF to certain directory
本文介绍了将网页保存为PDF到某个目录的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
Sub WebSMacro（）
Dim IE As Object
Dim Webloc As String
Dim FullWeb As String
Webloc = ActiveSheet.Range（B39）。值
FullWeb =http：//www.example.com =& Webloc
设置IE = CreateObject（InternetExplorer.Application）
IE.Visible = True
IE.Navigate FullWeb
尽管IE.Busy
Application.Wait DateAdd （s，1，Now）
循环
IE.ExecWB OLECMDID_PRINT，OLECMDEXECOPT_DONTPROMPTUSER
Application.Wait DateAdd（s，10，Now）
IE.Quit
设置IE =没有
End Sub
解决方案
今天你赢了互联网！
由于我想深入了解我的个人利益，所以我在第二个链接我在我的评论中引用了这个代码，就像你定义的那样工作。 p>
代码将进入FilePath和Name（从单元格中收集）到SaveAs对话框中，并将其保存到输入的位置。
这是主要的子（含评论）：
Sub WebSMacro（）
'将默认打印机设置为AdobePDF
Dim WSHNetwork As Object
设置WSHNetwork = CreateObject（WScript.Network）
WSHNetwork.SetDefaultPrinterAdobe PDF
'获取pdf作为路径从单元格范围
Dim sFolder As String
sFolder = Sheets（Sheet1）。范围（A1）'假定文件夹保存为路径在mySheets的单元格A1
Dim IE As Object
Dim Webloc As String
Dim FullWeb As String
Webloc = ActiveSheet.Range（B39）。值
FullWeb =http://www.example.com& Webloc
设置IE = CreateObject（InternetExplorer.Application）
与IE
.Visible = True
.Navigate FullWeb
Do While .Busy
Application.Wait DateAdd（s，1，Now）
循环
.ExecWB 6，2'OLECMDID_PRINT，OLECMDEXECOPT_DONTPROMPTUSER
Application.Wait DateAdd（s，3，Now）
调用PDFPrint（sFolder& Webloc&.pdf）
.Quit
结束
设置IE =没有
结束Sub
您还需要将这两个代码放置在您的工作簿中的某个位置（可以与主子（或不同的）相同的模块）：
Sub PDFPrint（strPDFPath As String）
'使用Adobe Professional将网页打印为PDF文件。
'API函数用于指定必要的窗口，而
'使用WMI函数来检查打印机的状态。
'作者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
'查找主打印窗口。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
Ret = 0
DoEvents
Ret = FindWindow（vbNullString，另存PDF文件）
如果Ret& ; 0然后退出Do
循环
如果Ret<> 0然后
SetForegroundWindow（Ret）
'查找第一个子窗口。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
ChildRet = 0
DoEvents
ChildRet = FindWindowEx（Ret，ByVal 0&DUIViewWndClassName，vbNullString）
如果ChildRet <> 0然后退出Do
循环
如果ChildRet<> 0然后
'查找第二个子窗口。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
ChildRet2 = 0
DoEvents
ChildRet2 = FindWindowEx（ChildRet，ByVal 0&DirectUIHWND，vbNullString）
如果ChildRet2 <> 0然后退出Do
循环
如果ChildRet2<> 0然后
'查找第三个子窗口。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
ChildRet3 = 0
DoEvents
ChildRet3 = FindWindowEx（ChildRet2，ByVal 0&FloatNotifySink，vbNullString）
如果ChildRet3 <> 0然后退出Do
循环
如果ChildRet3<> 0然后
'找到要编辑的组合框。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
comboRet = 0
DoEvents
comboRet = FindWindowEx（ChildRet3，ByVal 0&ComboBox，vbNullString）
如果comboRet <> 0然后退出Do
循环
如果comboRet<> 0然后
'最后，找到组合框的编辑属性。
StartTime = Now（）
直到现在（）> StartTime + TimeValue（00:00:05）
editRet = 0
DoEvents
editRet = FindWindowEx（comboRet，ByVal 0&Edit，vbNullString）
如果editRet <> 0然后退出Do
循环
'将PDF路径添加到打印窗口的文件名组合框。
如果editRet<> 0然后
SendMessage editRet，WM_SETTEXT，0& ByVal& strPDFPath
keybd_event VK_DELETE，0，0，0'按删除
keybd_event VK_DELETE，0，KEYEVENTF_KEYUP，0'release delete
'从完整路径获取PDF文件名。
On Error Resume Next
PDFName = Mid（strPDFPath，WorksheetFunction.Find（*，WorksheetFunction.Substitute（strPDFPath，\，*，Len（strPDFPath）_
- Len（WorksheetFunction.Substitute（strPDFPath，\，））））+ 1，Len（strPDFPath））
错误GoTo 0
'保存/打印网页按打印窗口的保存按钮。
Sleep 1000
ChildSaveButton = FindWindowEx（Ret，ByVal 0&Button，& Save）
SendMessage ChildSaveButton，BM_CLICK，0，0
有时打印延迟，特别是在大型彩色网页上。
'这里的代码检查打印机状态，如果是空闲的，这意味着
'打印完成。
直到CheckPrinterStatus（Adobe PDF）=空闲
DoEvents
如果CheckPrinterStatus（Adobe PDF）=错误然后退出执行
循环
'由于Adobe Professional在完成打印后打开，请找到
'打开的PDF文档并关闭它（使用帖子消息）。
StartTime = Now（）
直到开始时间> StartTime + TimeValue（00:00:05）
PDFRet = 0
DoEvents
PDFRet = FindWindow（vbNullString，PDFName& - Adobe Acrobat）
如果PDFRet< ;> 0然后退出Do
循环
如果PDFRet<> 0然后
PostMessage PDFRet，WM_CLOSE，0& 0&
End If
End If
End If
End If
End If
End If
End If
End Sub
函数CheckPrinterStatus（strPrinterName As String）As String
'如果打印机名称的函数返回一个字符串
'与打印机状态。
'作者Christos Samaras
'http://www.myengineeringworld.net
Dim strComputer As String
Dim objWMIService As Object
Dim colInstalledPrinters As Variant
Dim objPrinter As Object
'设置WMI对象并检查安装打印机。
On Error Resume Next
strComputer =。
设置objWMIService = GetObject（winmgmts：&{impersonationLevel = impersonate}！\\& strComputer&\root\cimv2）
设置colInstalledPrinters = objWMIService。 ExecQuery（从Win32_Printer选择*）
'如果在上一步中发生错误，该函数将返回错误。
如果Err.Number<> 0然后
CheckPrinterStatus =错误
结束如果
错误GoTo 0
'该函数循环所有安装的打印机和所选打印机
'检查它的状态。
对于每个objPrinter在colInstalledPrinters
如果objPrinter.Name = strPrinterName然后
选择案例objPrinter.PrinterStatus
案例1：CheckPrinterStatus =其他
案例2：CheckPrinterStatus = 未知
案例3：CheckPrinterStatus =空闲
案例4：CheckPrinterStatus =打印
案例5：CheckPrinterStatus =预热
案例6：CheckPrinterStatus =已停止打印
案例7：CheckPrinterStatus =离线
案例Else：CheckPrinterStatus =错误
结束选择
结束如果
下一个objPrinter
'如果有空白状态，函数返回错误。
如果CheckPrinterStatus =然后CheckPrinterStatus =错误
结束函数
最后在模块中声明这些常量和函数（可以是与主子（或不同的）相同的模块。
$ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $
$ b公共声明Sub Sleep Libkernel32_
（ByVal dwMilliseconds As Long）
公共声明函数FindWindow Libuser32 AliasFindWindowA_
（ByVal lpClassName As String，ByVal lpWindowName As String）As Long
公共声明函数FindWindowEx Libuser32别名FindWindowExA_
（ByVal hWnd1 As Long，ByVal hWnd2 As Long，ByVal lpsz1 As String，ByVal lpsz2 As String）As Long
公共声明函数SetForegroundWindow Libuser32_
（ByVal hWnd As Long）As Long
公共声明函数SendMessage Libuser32别名SendMessageA_
（ByVal hWnd As Long，ByVal wMsg As Long，ByVal wParam As Long，lParam As Any）As Long
公共声明函数SendMessageByString Libuser32别名SendMessageA_
（ByVal hWnd As Long，ByVal wMsg As Long，ByVal wParam As Long，ByVal lParam As String）As Long
公共声明函数PostMessage Libuser32别名PostMessageA_
（ByVal hWnd As Long，ByVal wMsg As Long，ByVal wParam As Long，lParam As Any ）As Long
公共声明Sub keybd_event Libuser32_
（ByVal bVk As Byte，ByVal bScan As Byte，ByVal dwFlags As Long，ByVal dwExtraInfo As Long）
'用于API函数的常量。
公共Const SW_MAXIMIZE = 3
公共Const WM_SETTEXT =& HC
公共Const VK_DELETE =& H2E
公共Const KEYEVENTF_KEYUP =& H2
Public Const BM_CLICK = &安培; HF5&安培;
Public Const WM_CLOSE As Long =& H10
I have it where it will open Internet Explorer give the user the save as box and then exit. However, I would prefer if instead of the user having to navigate to the correct folder, the directory comes from a cell in the worksheet and saves the webpage as a PDF. I have full Adobe installed. The code:
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
解决方案
Today, you win the Internet!
Since I wanted to learn this more in depth for my own personal benefit, I used the code in the 2nd link I referenced in my comment to get the code to work as you have defined it.
The code will enter the FilePath and Name (gathered from a Cell) into the SaveAs Dialog Box and save it to the entered location.
Here is the main sub (with comments):
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
You will also need to place this two subs somewhere in your workbook (can be the same module as the main sub (or different one)):
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
And finally Declare these constants and functions in a module as well (can be the same module as the main sub (or different one).
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
这篇关于将网页保存为PDF到某个目录的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
