インターネットでさがしもの

インターネットで探し物

かなりやばいものを作ってしまった。。。。ベクターには公開できんなぁ。。。。
「Mail De Watch」を作って以来、ちょっとしたインターネット通信プログラムがおもしろくなってしまい、情報収集機能をもつプログラムを作ってみたくなったんで
す。インターネットには情報があふれています。検索エンジンなどがよい例ですね。でも、いろんなサイトを探すのに手作業で探すのは面倒。知りたい情報を
もったページをスコンと抜けるとおもしろいなぁ、ということで今回は自動的に探すサンプルプログラムを作ってみました。
ただ。。。。。。。一番簡単な例としてメールアドレスを発見するようにしてみたのですが、巷にはMAILCATCHERとかMAILFINDERとかいっ
てそういうソフトがとても高価な値段で売られており、ヤバヤバツールと認定されているようです。まぁ、SPAMメールをばらまく元といえばそうですもん
ね。対抗策としてアクセスしてきたらデタラメなメールアドレスを大量に生成して返す、なんていうWPOISONなんていうおもしろいソフトを作っている人もいます。
というわけで今回はわざとパッケージには実行モジュールは含まれていません。あくまでも研究用にVBのソースだけ置いておきます。

このプロセスはふたつのフェーズにわけました。最初にやるべきことは、候補のURLを探すことです。例えばGoogleで検索結果のページでもいい
ですし、なんらかの形のリンク集を拾い出し、そのリンクを順順に辿ってみることにしました。一番重要なルーチンが以下のルーチンです。

 

   

      

   

 

      

Private Sub BtnStart_Click()
  Dim i As Long
  Dim Contents As String
  Dim ArrayBin() As Byte

  BtnStart.Enabled = False
  bitSTOP = False
 
  ListURL.Clear
 
  Call Init_Inet
 
  InetScan.URL = TxtURL.Text ----(1)
  On Error Resume Next
  ArrayBin() = InetScan.OpenURL(, icByteArray) ---(2)
  On Error GoTo 0
  Contents = StrConv(ArrayBin, vbUnicode)
 
  Call ScanLink(Contents) ---(3)
  DoEvents
  If ListURL.ListCount = 0 Then
    Exit Sub
  End If
  i = 0
  Do While (i < (ListURL.ListCount - 1))  ---(4)
    lblDoing.Caption = "リストの" & CStr(i) & _
"番目を調査中。発見したURL数は" & CStr(ListURL.ListCount)
   
    If CLng(TxtMaxURL.Text) < i Then
      InetScan.Cancel
      BtnStart.Enabled = True
      Exit Sub
    End If
    InetScan.URL = ListURL.List(i)
    On Error Resume Next
    ArrayBin() = InetScan.OpenURL(, icByteArray)
    On Error GoTo 0
    Contents = StrConv(ArrayBin, vbUnicode)
    Call ScanLink(Contents)
   
    DoEvents
   
    If bitSTOP Then ---(5)
      InetScan.Cancel
      BtnStart.Enabled = True
      Exit Sub
    End If
   
    i = i + 1
  Loop
 
  BtnStart.Enabled = True
 
End Sub

      

(1)で、InetScanというのは、VBのInetコンポーネントです。これはなかなか便利でプロキシーの設定などもできてHTTP(いわゆる
WEB)のデータを取ってきてくれます。その取る動作が(2)のopenURLというメソッドです。これだけでも、例えば右クリックができないようになっ
ているJavaScriptいりのページのソースを入手することができますね。ここはページがきちんと送られてこなかったり、タイムアウトでエラーになり
やすいのでon
Errorステートメントでエラーをキャンセルしています。うーん、通信プログラムっぽい。
インターネットで入手する情報はさまざまな文字コードで記述されています。EUC,SHIFT-JIS,UNICODEなど聞いたことがあるでしょう?で
すから、VBで処理する場合は普通のSTRINGではなく、バイト配列で受け取ります。STRINGはVBの思っている文字コード(UNICODE)に無
理に文字を変更しようとしたりするので、そういう心配のないバイト配列で受け取り、STRCONV関数でUNICODEに変更しています。これでもイマイ
チヘンなのですが、今回はURLという英語でしかできていないに決まっているものを扱うのでこれでいいことにしています。
(3)はそのもってきたページの内容からHTMLのHREFキーワードを見つけてリンクしているURLを拾い出そうというものです。見つけ出したURLは
すべてLISTBOXに書き出していますので、(4)の部分の数はどんどん増えていきます。つまりこのプログラムはリンクを拾い出してはそのリンクにアク
セスし、また、そのリンクを拾い出していくので放っておくとどこまでもURLを収集しまくってしまいます。で、(5)のタイミングで「中止ボタン」が押さ
れていないかチェックして押されていたら作業を止めるようになっています。
VBのソースパッケージはページの一番下にリンクがあります。実行してみると一万URLなんて簡単に集まるもんですね。ビックリ!データを保管するとき、
そのURLが目的のものか、正規表現でフィルタリングする機能もつけてみました。拾ったものをそのまま保管したい人はソースからregedit関連をとっ
ぱずすとよいでしょう。
以下はほぼ同じ機能をIEを利用してスクリプトで作った例。コレクションオブジェクトがスクリプトでは使えないんで配列の定義で拾いたい最大数を指定してください。BASP21を使っていますので、別途、インストールしてください。

 

   

      

   

 

      

' URLFinder.VBS by T.Takao

option explicit

Dim URLList( 1000 )
Const FileName = "URLList.csv" '書き出すファイル名

Dim objIE 'IEオブジェクト
Dim objFS 'ファイルシステムオブジェクト
Dim objFH 'ファイルシステムハンドル
Dim objBasp 'BASP21
Dim URL ' 最初のURL
Const ForAppending = 8
Dim i     'カウンター
Dim CountURL
Dim MaxURL '最大URL数
MaxURL = UBound(URLLIST)-1

Call Main()

msgbox "終了"
'---------------------------------------------------
Sub Main()
  dim stream


'IEのインスタンスを作成
Set objIE = CreateObject("InternetExplorer.Application")

Set objBasp = CreateObject("basp21")

URL = inputbox("最初のURLを入力します。(http:から)")
if URL = "" then
  Exit Sub
End if

' 最初のナビゲート
objIE.Navigate(URL)
Call LoadWait
objIE.Visible = True '動きをみたい方はこちらをどうぞ

CountURL = 0
for each URL in objIE.Document.Links
  URLList(CountURL) = objBasp.kconv( URL.Href,4)
  CountURL = CountURL + 1
next

i=0
Do while (CountURL < MaxURL)
  objIE.Navigate( URLList( i ) )
  i = i + 1
  Call LoadWait
  for each URL in objIE.Document.Links
    if CountURL > MaxURL then
      exit for
    end if
    URLList( CountURL ) = objBasp.kconv( URL.Href,4)
    CountURL = CountURL + 1
  Next
Loop

objIE.Quit
Set objIE = Nothing

Call WriteOut()

End Sub

sub LoadWait()

  'ロード待ち
  do while (objIE.busy)
  loop
  do while (objIE.Document.readyState <> "complete")
  Loop
End Sub


Sub WriteOut()
  Set objFS = CreateObject("Scripting.FileSystemObject")
  Set objFH = objFS.OpenTextFile(FileName, ForAppending, True)
  for i = 0 to MAXURL
    objFH.WriteLine URLLIST(i)
  next
  objFH.Close
  set objFS = Nothing
End Sub

      

続いて、URLからメールアドレス(あくまでも例ですよ、例!)を拾い出すプログラムの要の部分をご紹介しましょう。

 

   

      

   

 

      

Private Sub BtnStart_Click()
  Dim i As Long
  Dim Contents As String
  Dim ArrayBin() As Byte
  Dim URLname As Variant

  BtnStart.Enabled = False
  bitSTOP = False
 
  ListMail.Clear
 
   For i = 1 To colURL.Count
      colURL.Remove 1
   Next
 
  Call LoadURL
 
  Call Init_Inet
      
  For Each URLname In colURL ---(1)
    InetScan.URL = URLname
    On Error Resume Next
    ArrayBin() = InetScan.OpenURL(, icByteArray) ---(2)
    On Error GoTo 0
    Contents = StrConv(ArrayBin, vbUnicode)
    Call ScanAtMark(Contents) ---(3)
    DoEvents
    LblDoing.Caption = URLname & "探索中" & vbCrLf _
      & "発見したメアド数 " & CStr(ListMail.ListCount)
    If bitSTOP Then ---(4)
      InetScan.Cancel
      BtnStart.Enabled = True
      Exit Sub
    End If
   
  Next
  BtnStart.Enabled = True
End Sub

      

最初のプログラム(URLFinder)で探し出したURLはCSVファイルに保管されているとします。効率を高めたい人はリストをエクセルかなにかで処理して重複URLを除くといいでしょうね。
(1)ではLoadURLで読み込んだコレクションオブジェクトからひとつづつURL名を取り出しています。インターネットプログラムは最初のURLを探
すものとほぼ同じです。(2)でinetコンポーネントのopenURLメソッドでページを拾い出し、コード変換して、(3)でScanAtMarkで
メールにつきものの@マークを探しています。(4)は途中停止したいときの処理です。

いずれもネットワーク処理は簡単でした。むしろ難しいのは、読み込んだHTMLからどうやってリンクしているURLを取り出すか、どうやってメールアドレスを取り出すか、というテキスト処理部分でした。
このサンプルプログラムでは、HREFタグを見つけたら、そこを候補として切り出します。
次に、文字列を解析しダブルクォーテーションやブランクという区切りを見つけ、URLとしています。しかしやってみるとわかるように結構、ゴミも拾いま
す。同様にメールも@マークを見つけ前後50バイトを取り出し、@マークを中心としてアカウントとドメイン名を拾い出すという作業をやっています。これも
やってみるとわかるように@niftyなんてのも拾ってきてタイヘンです。
こうやってみると、インターネットから情報を収集するプログラムはデータをもってくるのは簡単で、そのテキスト処理がタイヘンであることがわかりました。時間ができたらページの要約を抽出できないかやってみたいところです。

 

   

      

   

   

      

   

   

      

   

 

悪用厳禁!
URL見つけるプログラムパッケージはここ
メアド見つけるプログラムパッケージはここ

コメント