法律関連整形スクリプトの少し手直し版

国の法令検索から条文を引っ張ってきて加工するというスクリプトを
作成すべく、先に挑戦していたわけですが・・・、とてもじゃないけど
手が出ない・・・。
構造が解析できないのでうまく取れない。
それに「編」とか「節」とか「款」がうまく取れないみたい。
本文もきれるのがあるし使えないけれども、ひとまずのバックアップとして
※特許法とかの知財関連の法案が取れればいいんですけどね・・・。

機能としては
法令検索から条文のソースを引いてきて、EXCELで加工して保存します。
自分で使うのでエラー処理は甘めです。

もし使う場合は自己責任で使ってくださいね。
Googleの仕様が変わると修正が必要です。
もっときれいにできるよとか、うまく改造できる方いらっしゃったら
ご指摘いただけると幸いです。
2016/8/19　動かない箇所があったので修正版に置き換えました。

' ◆参照サイト
' ◆参照サイト
' http://www.kanaya440.com/contents/tips/vbs/007.html
' http://www.takeash.net/wiki/?VBScript
' http://d.hatena.ne.jp/ken3memo/20090903/1251991651
' http://plaza.rakuten.co.jp/densen/diary/201310200000/
' http://fanblogs.jp/fjt/archive/58/0
' http://foundknownanddone.blogspot.jp/2014/05/IE-Internet-Explorer-automation-VBScript-DOM-WSH-waitIE.html
' http://so-zou.jp/software/tech/programming/vba/sample/web.htm
' http://www.koutou-software.net/junk/use-vs-project-with-vbscript.html
' http://vbsguide.seesaa.net/article/144608106.html
' http://homepage2.nifty.com/nonnon/Chinamini/20110001/20110201.html
' http://chaichan.lolipop.jp/vbtips/VBMemo2008-11-10.htm
' http://eprostation.jpn.org/vb/vbknow.html
' http://www.keep-on.com/excelyou/2000lng4/200005/00050155.txt
' http://korikorikorikori.blog.fc2.com/blog-entry-26.html
' http://excel-ubara.com/excelvba1/EXCELVBA310.html

'//
'// Googleで検索した法律関連ページのHTMLを取得して整形する。
'//
'// Proxy環境の場合はDOSプロンプトで実行 netsh winhttp import proxy source=ie
  
Option Explicit
  
Dim sURI
Dim rProvisions
Dim saveFile
Dim oFilename
Dim sKeyword
  
'// メイン部分
sKeyword = inputbox("ダウンロード対象法律名を入れてください。","検索ワード入力","特許法")
If IsEmpty(sKeyword) = true Then
  MsgBox "キャンセルが選択されました"
  WScript.Quit
Else
  If sKeyword = ""  Then
    MsgBox "文字が入力されていません"
    WScript.Quit
  End if
  If InStrRev(sKeyword,"法") = 0  Then
    MsgBox "●●法という形で入力してください。"
    WScript.Quit
  Else
    oFilename = "C:\Temp\" + sKeyword +".html"
  End If
End If
 
  
sURI = getURL(sKeyword)
rProvisions = getHTML(sURI)
saveFile = byFile(rProvisions,oFilename)
formattingHTML(oFilename)
 
if sURI = "False"  Or IsObject(rProvisions) = "True" Or saveFile = "False" then
 MsgBox "notComplete"
else
 MsgBox "Complete"
end if
 
  
'// Googleでキーワード検索1位のURL(下に緑で出てる▼のやつ)を取得する
function getURL(sKeyword)
  getURL = "False"
  Dim objIE
  Dim rURL
  
  Set objIE = CreateObject("InternetExplorer.Application")
  objIE.Visible = false
  objIE.Navigate("https://www.google.co.jp/search?q=" & sKeyword)
  Do While ObjIE.Busy = True Or ObjIE.readystate ＜＞ 4
      WScript.Sleep 200
  Loop  
 '// GoogleからURL取得
rURL =objIE.document.getElementByID("ires") _
        .getElementsByTagName("ol")(0) _
        .getElementsByTagName("cite")(0) _
        .innertext
         
 '// 有無を言わさず先頭にhttp://を付ける・・・
  getURL = "http://" + rURL
  
  objIE.Quit
  Set objIE = Nothing
end function
  
 
'// 対象ページのHTMLを取得する。
function getHTML(sURI)
  getHTML = "False"
   
  Dim oHttp
  Set oHttp = CreateObject("MSXML2.XMLHTTP")
   
  oHttp.Open "GET", sURI, False
  oHttp.Send
 
  If (oHttp.Status ＜＞ 200 ) Then
  MsgBox  "error:" & oHttp.Status
  getHTML = "False"
  end If
 
  getHTML = oHttp.responseBody
  Set oHttp = Nothing
end Function
 
 
'// HTMLを保存する。
function byFile(htmlBody,oFilename)
  byFile = "False"
  Dim ADODB
  Set ADODB = CreateObject("ADODB.Stream")
 
  With ADODB
 .Type = 1 'adTypeBinary
 .Open()
 .Write htmlBody
 .SaveToFile oFilename , 2 '1:adSaveCreateNotExist, 2:adSaveCreateOverWrite
 .Close
  End With
   
  Set ADODB = Nothing
  byFile = True
 
end Function
 
 
'//条文見出しと条文を加工する。
'// 取得したHTMLファイルィから条文とタイトルを取得して整形する。
'// 条件に合致した内容をEXCELの指定箇所にエクスポートする。
function formattingHTML(iFile)
  formattingHTML = "False"
 
  Dim workHtml             '作業用一時領域
  Dim outPut             '出力用
  Dim pChapter             '章
  Dim pTitle             '条文見出
  Dim pItem                 '条文
  Dim pNumber             '号
  Dim pText                 '本文
  Dim oXls
 
 
  Dim objFileSystem
  Dim objFile
 
  Dim objExcel
  Dim excelBook
  Dim excelSheet
  Dim excelCell
  oXls = iFile & ".xlsx"
  oXls = Replace(oXls,".html","")
  Dim textCount             '整形用
  Dim bodyRow               '出力用行
  Const firstRow = 2
  Const headingRow = 1      'EXCEL1行目（タイトル行）
  Const chapterColumn = 1 '章
  Const titleColumn = 2     '条文見出し
  Const itemColumn = 3     '条文
  Const numberColumn = 4    '号
  Const textColumn = 5     '本文
 
  Const chapWord = "＜P＞　　　＜B＞＜A NAME="
  Const titleWord = "＜DIV class=""arttitle""＞"
  Const itemWord = "＜DIV class=""item""＞＜B＞"
  Const numberWord = "＜DIV class=""number""＞＜B＞"
  Const textWord = "。"
 
  '// 元のHTMLオープン
  Set objFileSystem = CreateObject("Scripting.FileSystemObject")
  Set objFile = objFileSystem.OpenTextFile(iFile)
 
  '// EXCELオープン
  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = False
  objExcel.DisplayAlerts = False
  objExcel.WorkBooks.Add
  Set excelBook = objExcel.WorkBooks(objExcel.WorkBooks.Count)
  Set excelSheet = excelBook.Worksheets(1)
 
  '// 見出し作成,出力位置を2列目からに指定
  excelSheet.Cells(headingRow,chapterColumn).Value = "章"
  excelSheet.Cells(headingRow,titleColumn).Value = "条文見出し"
  excelSheet.Cells(headingRow,itemColumn).Value = "条"
  excelSheet.Cells(headingRow,numberColumn).Value = "号"
  excelSheet.Cells(headingRow,textColumn).Value = "本文"
  bodyRow = firstRow
 
  outPut = ""
  textCount = firstRow
  Do Until objFile.atEndOfStream
     If textCount ＞  bodyRow Then
        bodyRow = textCount
     End if
 
     workHtml = objFile.readline
 
      If InStr(workHtml,chapWord) ＜＞ 0 Then
       pChapter = workHtml
        pChapter = htmlReplace(pChapter)
        excelSheet.Cells(bodyRow,chapterColumn).Value = pChapter
      End if
 
      If InStr(workHtml,titleWord) ＜＞ 0 Then
        pTitle = workHtml
       pTitle = htmlReplace(pTitle)
        excelSheet.Cells(bodyRow,titleColumn).Value = pTitle
      End if
 
      If InStr(workHtml,itemWord) ＜＞ 0 Then
       pItem = workHtml
        pItem = htmlReplace(pItem)
        excelSheet.Cells(bodyRow,itemColumn).Value = pItem
      End if
 
      if InStr(workHtml,numberWord) ＜＞ 0 Then
        pNumber = workHtml
        pNumber = htmlReplace(pNumber)
        excelSheet.Cells(bodyRow,numberColumn).Value = pNumber
      End if
 
      if InStr(workHtml,textWord) ＜＞ 0 Then
        pText = workHtml
        pText = htmlReplace(pText)
        excelSheet.Cells(bodyRow,textColumn).Value = pText
        textCount = textCount + 1
      End if
  Loop
 
  '// セル幅整形
  excelSheet.Activate
  excelSheet.Columns(chapterColumn).AutoFit
  excelSheet.Columns(titleColumn).ColumnWidth = 73.25
  excelSheet.Columns(itemColumn).ColumnWidth = 16.38
  excelSheet.Columns(numberColumn).AutoFit
 
  if Err.Number ＜＞ 0 then
    MsgBox( "EXCEL処理失敗:" & Err.Description )
  end if
 
  excelBook.SaveAs(oXls)
  objExcel.DisplayAlerts = True
  objExcel.Visible = True
  objExcel.Quit
  Set objExcel = Nothing
 
  objFile.Close
  objFileSystem.DeleteFile(iFile)
 
  If Err.Number ＜＞ 0 Then
        MsgBox "一時ファイル削除失敗: " & Err.Description
  End If
 
  Set objFile = Nothing
  Set objFileSystem = Nothing
 
end function
 
 
' https://sites.google.com/site/scriptmakerms/scriptmakerms/regular_expression/tag
'// HTMLタグを取り除く
Function htmlReplace(str1)
  Dim regEx
  Dim patrn
  Dim replStr
  patrn="＜(""[^""]*""|'[^']*'|[^'""＞])*＞"
  replStr=""
 
  Set regEx = New RegExp
  regEx.Pattern = patrn
  regEx.Global = True
  regEx.IgnoreCase = True
  htmlReplace = regEx.Replace(str1, replStr)
End Function
 
  
'// IEがビジー状態の間待ちます
Sub waitIE(ie)
    Do While ie.Busy = True Or ie.readystate ＜＞ 4
        WScript.Sleep 100
    Loop
    WScript.Sleep 1000
End Sub