使用vbs自动化批量保存网页为mht_V1

' 下载宝，加强使用脚本从网络上提取信息能力；

' 与python，wget的区别；对于信息的认识能力；

Dim EvtSrc, WS, FS, URL, Path, Title, EN, filespec, msg, IE

Set WS = CreateObject("WScript.Shell")

Set FS = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

'Set EvtSrc=external.menuarguments.event.srcelement

'EN = Err.Number

On Error GoTo 0

'If EN <> 0 Then Reg_UnReg

'---------------------------------------------------------------------------------------------

' Function:  CleanStringForFileName

'

'    Replaces invalid characters in file names for "_"

'      

'            Created by Israel Burman

'

'---------------------------------------------------------------------------------------------

Function CleanStringForFileName(strText )

strText =Replace(strText,"/",",")
strText =Replace(strText,"\",",")
strText =Replace(strText,"<","(")
strText =Replace(strText,">",")")
strText =Replace(strText,":","")
strText =Replace(strText,"*","")
strText =Replace(strText,"?","")
strText =Replace(strText,"|","")

strText =Replace(strText," ","_")

strText =Replace(strText,",,","-")

strText =Replace(strText,",","-")
'if strPackage comes from IIS 6 (-ap) it may have " delimiters. Cleaning this up as well
strText =Replace(strText,"""","-")

CleanStringForFileName = strText

End Function

'---------------------------------------------------------------------------------------------

' Function:  ReplaceReservedChars

'

'    Replaces special reserved xml chars

'

'       &(&), <(<), >(>), &apos('), "(")

'      

'            Created by Israel Burman

'

'---------------------------------------------------------------------------------------------

Function ReplaceReservedChars(strText )

strText =Replace(strText,"&","&")
strText =Replace(strText,"&","&")
strText =Replace(strText,"&Amp;","&")

strText =Replace(strText,"<","<")
strText =Replace(strText,"<","<")
strText =Replace(strText,"≪","<")

strText =Replace(strText,">",">")
strText =Replace(strText,">",">")
strText =Replace(strText,"≫",">")

strText =Replac
4000
e(strText,"'","'")
strText =Replace(strText,"&APOS;","'")
strText =Replace(strText,"&Apos;","'")

strText =Replace(strText,""","""")
strText =Replace(strText,""","""")
strText =Replace(strText,""","""")

ReplaceReservedChars = strText

End Function

'

Sub SaveAsMhtml(URL)

    On Error Resume Next

    'URL = EvtSrc.Href

    If IsNull(URL) Or LCase(Left(URL, 7)) <> "http://"  Or LCase(Left(URL, 8)) <> "https://" Then _

    ShowMessage 1

    Path = "%userprofile%\My Documents\HomePages\"

    Path = WS.ExpandEnvironmentStrings(Path)

    If Not FS.FolderExists(Path) Then FS.CreateFolder Path

    'external.menuarguments.status = "Now downloading..."
'创建线程方式来完成？怎么去解决，降低内存的溢出问题。
'Set IE

    With CreateObject("InternetExplorer.Application")

        .Navigate URL

        Do While .Busy: Loop
'一些特殊字符需要进行处理，防止出现: /等导致无法创建目录的情况

        Title = .Document.Title:If Title = "" Then Title = "__"

        filespec = Path & Replace(Title, ":", "_") & ".mht"
'需要解决重名问题

        If (FS.FileExists(filespec)) Then

          msg = "help"

        Else

          With CreateObject("CDO.Message")

            On Error Resume Next

            .CreateMHTMLBody(URL)

            'If Err Then On Error GoTo 0: ShowMessage 2

            FS.CreateTextFile filespec

            If Err Then _

            Title = Replace(Date, "/", "_") & "_" & Replace(Time, ":", "_") & ".mht"

            On Error GoTo 0
' Q：为何直接使用filespec会失败呢？

            .BodyPart.GetStream.SaveToFile Path & Replace(Title, ":", "_") & ".mht", 2
' 不需要关闭，是否内存泄漏？

          End With

       End If

       .Quit

    End With

    'external.menuarguments.status = ""

    ShowMessage 3

End Sub

'

Sub ShowMessage(Mes)

    'Select Case Mes

    'Case 1: WS.PopUp "No link address.", 2

    'Case 2: WS.PopUp "Downloading failed", 2

    'Case 3: WS.PopUp "Downloading finished.", 2

    'End Select

    'window.close

End Sub

'

Sub Reg_UnReg()

    Const RootKey = "HKCU\Software\Microsoft\Internet Explorer\MenuExt\"

    Const Name = "SaveAs &Mht Format"

    Dim Path, TKey, Dummy, EN

    Path = document.urlunencoded

    TKey = RootKey & Name & "\"

    On Error Resume Next

    Dummy = WS.RegRead(TKey): EN = Err.Number

    On Error GoTo 0

    If EN = 0 Then

        WS.RegDelete TKey

        WS.PopUp "Deleted from context menu", 2

    Else

        WS.RegWrite TKey, Path, "REG_SZ"

        WS.RegWrite TKey & "contexts", &H20, "REG_DWORD"

        WS.PopUp "Added to context menu", 2

    End If

    'window.close

End Sub

'  从文件中读取数据的过程，并循环处理每个条目

Sub ReadFiles

   Dim fso, f1, ts, s

   Const ForReading = 1

   Set fso = CreateObject("Scripting.FileSystemObject")

   'Set f1 = fso.CreateTextFile("c:\testfile.txt", True)   ' 写一行。

   'Response.Write "Writing file <br>"

   'f1.WriteLine "Hello World"

   'f1.WriteBlankLines(1)

   'f1.Close   ' 读取文件的内容。

   'Response.Write "Reading file <br>"

   '文本需要是windows换行方式

   Set ts = fso.OpenTextFile("c:\1.txt", ForReading)

   Do While Not ts.AtEndOfStream

       s = ts.ReadLine

       'Response.Write "File contents = '" & s & "'"

       SaveAsMhtml(s)

   Loop

   ts.Close

End Sub

ReadFiles