Googleで検索して検索1位のサイトをダウンロードする。

弁理士関連で法律が年に1回変わるので学習ツールとか

作る際に、条文をダウンロードするのがなぁとおもっていたので

その元ネタでサンプル作成してみたよ。

Googleをキーワード検索して一番上にあるやつの

緑タイトルを拾ってそこにアクセスしてページソースをダウンロードする

というもの。エラー処理とかないので取扱いは慎重にした方が

いいですよ。

で以下、ソース。まさかCITEタグとは思いもしませんでした。
後はダウンロードした後にEXCELに加工して取り込めば楽できるな。
skeywordを他の法律に変えれば別の法律も取得できます。
法令検索の結果が一番に表示されるなら加工もしやすいかな・・・。

'//
'// 特許法のページソースを取得する
'//
'// Proxy環境の場合はDOSプロンプトで実行 netsh winhttp import proxy source=ie

Option Explicit

Dim sURI
Dim rgetHtml
Dim oFilename
Dim sKeyword

'// メイン部分
sKeyword = "特許法"
oFilename = "C:\temp\" + sKeyword +".txt"

sURI = getURL(sKeyword)

if sURI = False then
 MsgBox "notComplete"
end if

rgetHtml = getHTML(sURI,oFilename)
if rgetHtml=True then
 MsgBox "Complete"
end if

'// Googleでキーワード検索1位のURL(下に緑で出てる▼のやつ)を取得する
function getURL(sKeyword)
 Dim objIE
 getURL = False
 Dim rURL

 Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = False
 objIE.Navigate("https://www.google.co.jp/")
 waitIE objIE
 objIE.Document.getElementById("q").Value = sKeyword
    WScript.Sleep 100
 objIE.Document.all("btnG").Click
 waitIE objIE

 '// GoogleからURL取得
    rURL =objIE.document.getElementByID("ires") _
        .getElementsByTagName("li")(0) _
        .getElementsByTagName("cite")(0) _
        .innertext
 '// 有無を言わさず先頭にhttp://を付ける・・・
 getURL = "http://" + rURL

end function


'// URLを受取ってそのサイトの内容をtxt形式で保存する。
function getHTML(sURI,oFilename)
 Dim http
 Dim sHTML
 Dim ADODB
   
 '// 変数を初期化  
    getHTML = False
 Set http = CreateObject("WinHttp.WinHttpRequest.5.1")  
    Set ADODB = CreateObject("ADODB.Stream")
   
 '//ページソースを取得
 With http  
     .Open "GET", sURI, False         
     .Send  

  If .Status <> 200 Then  
         Err.Raise 5, , "HTML の取得に失敗"  
     Else  
 '//ファイルに書き込み
      With ADODB
          .Type = 1 'adTypeBinary
          .Open
          .Write http.responseBody
          .SaveToFile oFilename , 1 '1:adSaveCreateNotExist, 2:adSaveCreateOverWrite
          .Close
      End With
     End If  
 End With  

 getHTML = True
    Set http = Nothing
    Set ADODB = Nothing

End function


'// IEがビジー状態の間待ちます
Sub waitIE(ie)
    Do While ie.Busy = True Or ie.readystate <> 4
        WScript.Sleep 100
    Loop
    WScript.Sleep 1000
End Sub