将指定网址的网页另存为MHT格式（VBA）

时　间:2014-11-13 21:29:07
作　者:Big Young   ID：252  城市：襄阳
摘　要:用VBA将指定网址的网页另存为MHT格式。
正　文:

有时为了收集资料，需要批量将一个网站的多个网页保存下来，有了这几个过程或函数，就可以自动的完成工作了。使用方法：在VBE里先插入一个标准模块，然后再将下面的代码粘贴进去就可以使用了，非常简单。

' 引用： Microsoft ActiveX Data Objects 2.5 Library
' 引用： Microsoft CDO for Windows 2000 Library (cdosys.dll)

Sub TestSaveAsMht()
  UrlToMht "http://www.xf4hs.com/", "D:\Temp\1.mht"
  SavePageToMHT "http://www.xf4hs.com/", "D:\Temp\abc.mht"
End Sub
 
Sub UrlToMht(URL As String, Mht As String)
    Dim oCDOMessage As Object
    Set oCDOMessage = CreateObject("CDO.Message")
    With oCDOMessage
        .MimeFormatted = True
        .CreateMHTMLBody URL, 0, "", ""
        .GetStream.SaveToFile Mht, 2
    End With
    Set oCDOMessage = Nothing
End Sub

Function SavePageToMHT(ByVal URL As String, ByVal FileName As String) As Boolean
    Dim objMsg As Object
    Set objMsg = CreateObject("CDO.Message")
    Dim objStream As Object
    Set objStream = CreateObject("ADODB.Stream")
    On Error GoTo Err_Handle:
    objMsg.CreateMHTMLBody URL, , "qwemini1", "qwemini1"
    Set objStream = objMsg.GetStream
    objStream.SaveToFile FileName, 2  'adSaveCreateOverWrite
    SavePageToMHT = True
Sub_Handle:
    Set objMsg = Nothing
    Set objStream = Nothing
    Exit Function
Err_Handle:
    MsgBox "错误： " & Err.id & " 号。错误说明： " & Err.Description & "。", vbOKOnly, "系统错误"
    SavePageToMHT = False
    GoTo Sub_Handle:
End Function