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

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

機能としては
法令検索から条文のソースを引いてきて、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

コメント

Otazoman さんの投稿…
2/14　78行目の箇所修正しないと動かなくなってた・・・・

'// GoogleからURL取得
rURL =objIE.document.getElementByID("ires") _
.getElementsByTagName("cite")(0) _
.innertext
2016年2月14日 8:55
コメントを投稿

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

-
 タイトルのまんまです。 以前、EXCELで似たようなこと をしていたのでGASではどうするのかなぁと思ってやってみました。まぁほとんど丸パクリです。とりあえず、また使うかもしれないので自分用にメモです。しかしGASでGoogleDriveのファイル一覧嘗め回そうとすると3分かかってしまう。数が多いと6分制限に引っかかるのでこれでは使えない。せいぜい100ファイルとか数が少ないところで使う分にはいいけどダイナミックな場合は何回かに分割してやらないと少し厳しいかもしれない。 ◆GAS //設定値取得 const SHEET_URL = SpreadsheetApp.getActiveSpreadsheet().getUrl(); const ss = SpreadsheetApp.openByUrl(SHEET_URL); const SETTING_SHEET = ss.getSheetByName('設定') const TARGET_FOLDER_ID = SETTING_SHEET.getRange('B2').getValue(); const SAVE_FOLDER_ID = SETTING_SHEET.getRange('B3').getValue(); const SAVE_FILE_NAME = SETTING_SHEET.getRange('B4').getValue(); const SAVE_SHEET_NAME = SETTING_SHEET.getRange('B5').getValue(); function writeSheet(values, labels, sheetUrl, sheetname, width) { /* スプレッドシートに書き出し */ try { if (values.length > 0) { // シートを追加する let spreadSheet = SpreadsheetApp.openByUrl(sheetUrl); let sheet = set_sheet(sheetUrl,sheetname); // 1行目だけヘッダ追加 let he...
続きを読む

マクロ経済学(IS-LM分析)

-
イメージ
危うく3日坊主になりそうでした。とりあえず今日は 「IS-LM分析」 です。 テキストでは 簡便4象限法 とかいうのの説明が多いです。なのでさっぱり わけわからん状態ですが、それなりに頑張ってみます。 1: IS曲線 の導出 財市場の均衡を表す。Iは投資を表し、Sは貯蓄を表す。 ・IS曲線導出の材料 I→利子率の関数、S→所得の関数で「I=S」で財市場を表す。 ・ 投資関数 利子率の減少関数、I (投資関数)=I(r)　※rは利子率 ・政府活動の導入 裁量的な拡張的な財政政策はIS曲線をシフトさせる。 IS曲線の右シフト=政府支出の増大や減税等の有効需要を増加させる要因による 2: LM曲線 の導出 利子率の低下が国民所得の増大につながる因果関係を明らかにする目的 ・LM曲線導出の材料 貨幣需要(MD)=L、L=取引的動機+予備的動機(L1)+投機的動機(L2) MD=L1+L2 貨幣供給(Ms)=名目貨幣供給/物価(P) ・LM曲線のシフト 金融緩和策・物価下落：実質貨幣供給(MS)が増大→右(下)へシフト 金融引締策・物価上昇：実質貨幣供給(MS)が減少→左(上)へシフト 独立投資拡大→IS曲線が右にシフト 利子率がr1→r2に下落する。 IS曲線、LM曲線の均衡点がE→Fに移動する。 国民所得がY1→Yfとなって増大する。 3:特殊なLM曲線 ・ 流動性の罠 のLM曲線 金融政策は無効→LM曲線をシフトさせても均衡点Eは変わらない IS曲線を右にシフトさせる拡張的な財政政策を実施すると均衡点が E→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　 ・ 投資の利子率に対する弾力性ゼロ 金融政策は無効→LM曲線を右にシフトさせても国民所得が増えない。 流動性の罠と同じくIS曲線を右にシフトさせる拡張的な財政政策を実施すると 均衡点がE→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　　　　 4: クラウディング・アウト 政府が市場に介入して公共投資を行うと民間の投資が締出しを受ける ・古典派による財政政策の無効論 政府支出を拡大すると利子率が上昇してしまい。投資が減少する。 政府の支出がクラウディングアウトを引き起こして支...
続きを読む

IEのセキュリティ設定をいじくるバッチ

-
まぁかなり頻出ですがIEでアプリ用に設定しないといけなくて クリックOnlyで処理したかったので色々と調べてみて作ってみた。 ローカルイントラネットの設定いじくるのとActiveX関連をいじくるのと 互換表示設定をいじくっています。 というよりそういう設定しないと動かないアプリの組み方辞めてください。 頼むから・・・。 挙動が微妙に他と違うのでIEとかEdgeには苦しめられます。 @echo off set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap" reg add %REGROOT% /f /v "AutoDetect" /t REG_DWORD /d "0" reg add %REGROOT% /f /v "IntranetName" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "ProxyBypass" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "UNCAsIntranet" /t REG_DWORD /d "1" rem IEのローカルイントラネット設定(*ドメイン指定) set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range1" set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\対象ドメイン" reg add %REGROOT% /f /v "*" /t REG_DWORD /d "1" rem スクリプトを実行しても安全だとマークされていない activex コントロールの初期化とスクリ...
続きを読む