[文本处理] 【已解决】网页文本如何用批处理提取问题

arr = Array("ssNumber", "bookName", "author", "pageNum", "publish", "isbn")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f in fso.GetFolder(".").Files
        If LCase(Right(f, 4)) = ".htm" Then
                Name = fso.GetBaseName(f) & ".csv"
                fso.OpenTextFile(Name, 2, true).Write getData(f, arr)
        End If
Next

MsgBox "OK"

Function getData(file, ByVal arr)
        s = Join(arr, ",") & vbCrLf
        with CreateObject("ADODB.Stream")
                .Mode = 3
                .Type = 2
                .Open
                .CharSet = "utf-8"
                .LoadFromFile file
                txt = .ReadText
        End with
        Set re = New RegExp
        re.Pattern = "\{[\s\S]+?}"
        re.Global = true
        re.IgnoreCase = true
        For Each m in re.Execute(txt)
                ReDim a(UBound(arr))
                For i = 0 to UBound(arr)
                        re.Pattern = """" & arr(i) & """:("".+?"")"
                        If re.Test(m) Then a(i) = re.Execute(m)(0).SubMatches(0)
                Next
                s = s & Join(a, ",") & vbCrLf
        Next
        getData = s
End Function
复制代码

'提取JSON文本.vbs   by yu2n 20150420
Main
Sub Main()
  Dim arrName, SaveFile, fso, f
  arrName = Array("ssnumber", "bookName", "author", "pageNum", "publish", "isbn")                 'JSON名称
  SaveFile = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
  SaveFile = SaveFile & Left(WScript.ScriptName, InStrRev(WScript.ScriptName, ".")-1) & ".csv"    '结果保存位置

  ' 遍历同目录所有 *.htm 文档
  Set fso = CreateObject("Scripting.FileSystemObject")
  fso.OpenTextFile(SaveFile, 2, True, -1).Write Join(arrName, ",") & vbCrLf         '重置TXT，写入JSON名称
  For Each f in fso.GetFolder(".").Files
    If LCase(Right(f, 4)) = ".htm" Then
      fso.OpenTextFile(SaveFile, 8, True, -1).Write getData(f, arrName) & vbCrLf    '追加写入TXT
    End If
  Next

  MsgBox "OK"
End Sub

Function getData(file, arrName)
  Dim strJson
  strJson = ReadPfile(file, "UTF-8")  '以UTF-8编码读取JSON文文本
  getData = GetJsonString(strJson, arrName)          '获取JSON值
End Function

'按编码读取txt文件内容
Function ReadPfile(ByVal File, ByVal Charset)
With CreateObject("ADODB.Stream")
  .Type = 2
  .Mode = 3
  .open
  .Charset = Charset
  .LoadFromFile File
  ReadPfile = .ReadText
  .Close
End With
End Function

'获取JSON字符串中的数据 by yu2n 20150420
'GetJson("{ ""myname"":""liucqa"", ""myid"":""007"" }", Array("myid")) = "007"
Function GetJsonString(strJson, arrName)
  On Error Resume Next
  Dim oHTML, oWindow
  Set oHTML = CreateObject("htmlfile")
  Set oWindow = oHTML.parentWindow
  oWindow.ExecScript "var arr=[], s;" & _
    "var json=" & strJson & ";" & _
    "var arrName=['" & Join(arrName, "','") & "'];" & _
    "if(json instanceof Array){" & _
    "  for(var i=0;i<json.length;i++){" & _
    "    var arrTemp=[];" & _
    "    for(var j=0;j<arrName.length;j++){" & _
    "      arrTemp.push('""' + eval('(json[' + i + '].' + arrName[j] + ')' ) + '""')" & _
    "    }" & _
    "    arr.push(arrTemp.join(','));" & _
    "  };" & _
    "  s=arr.join('\r\n');" & _
    "}else{" & _
    "  for(var j=0;j<arrName.length;j++){" & _
    "    arr.push('""' + eval('(json.' + arrName[j] +')') + '""')" & _
    "  }" & _
    "  s=arr.join(',');" & _
    "}"
  GetJsonString = oWindow.s
End Function
复制代码