使用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
'
'       &amp(&), &lt(<), &gt(>), &apos('), &quot(")
'      
'            Created by Israel Burman
'
'---------------------------------------------------------------------------------------------
Function ReplaceReservedChars(strText )


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


strText =Replace(strText,"&lt;","<")
strText =Replace(strText,"&LT;","<")
strText =Replace(strText,"&Lt;","<")


strText =Replace(strText,"&gt;",">")
strText =Replace(strText,"&GT;",">")
strText =Replace(strText,"&Gt;",">")


strText =Replace(strText,"&apos;","'")
strText =Replace(strText,"&APOS;","'")
strText =Replace(strText,"&Apos;","'")


strText =Replace(strText,"&quot;","""")
strText =Replace(strText,"&QUOT;","""")
strText =Replace(strText,"&Quot;","""")




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