Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Excel 2016)
XMLHTTP60 の .send 時のエラーについて
投稿日時: 19/07/12 14:53:49
投稿者: もみじっこ

エラーメッセージなどをキーに自分なりに調査をしてみたのですが、どうしても解決できません。
お知恵を貸していただけませんでしょうか。よろしくお願いします。
  
<概要>
現在、ホームページ検索結果から、1件目のURL、住所・電話番号等を取得しExcelシートに出力するツールを作成しています。
途中まで順調に処理が進んでいるのですが、12〜13件目にさしかかるとエラーが発生しており、解決策を探しております。
  
<エラーメッセージ>
検索URLを実行する箇所の、「HttpReq.send」でエラー
 HttpReq.Open "GET", contentsURL
  HttpReq.send
  
「 実行時エラー'2147024891(80070005)'
  アクセスが拒否されました。     」
  
<参照設定>
VB for Aptications
OLE Automation
Micorosoft Excel 16.0 Object Library
Micorosoft Office 16.0 Object Library
Microsoft Internet Controls
Microsoft WinHTTP Services,Version5.1
Microsoft ActiveX Data Objects 6.1 Library
  
  
<ソース該当箇所>
以下と類似した処理を、5つ(URL・住所・電話番号・他2種類)実行し次のキーワードへ・・とループ処理をしています。
12〜13件目で処理が止まります。
  
Sub GetURL(contentsURL As String, counter As Long)
  
  Dim HttpReq As XMLHTTP60
  Dim oHtml As New MSHTML.HTMLDocument
  Dim objTag As Object '検索結果取得用
  Dim PageTitle As String 'リンクのページタイトル取得用
  Dim sURL As String 'リンク取得用
  
  Set HttpReq = New XMLHTTP60
  
  'URL実行
  HttpReq.Open "GET", contentsURL
  HttpReq.send ★エラー発生個所
  
  Do While HttpReq.readyState < 4
    DoEvents
  Loop
   
  'データを返す
  oHtml.body.innerHTML = HttpReq.responseText
  
  'タグ<a>(リンク)の数だけループ
  For Each objTag In oHtml.getElementsByTagName("a")
  
    '「LC20lb」Classの時だけ処理
    If InStr(objTag.outerHTML, "LC20lb") > 0 Then
     
      'オブジェクト(リンク)を格納
      sURL = objTag
  
      '検索結果1件目のURLを出力
      With ws1
        .Range("C" & counter).WrapText = False
        .Hyperlinks.Add anchor:=.Range("C" & counter), Address:=sURL
  
        ' 初期化処理
        Set HttpReq = Nothing
        Set oHtml = Nothing
      End With
      
      '処理終了
      Exit Sub
    End If
  Next 
End Sub
  
よろしくお願い致します。

回答
投稿日時: 19/07/12 21:38:25
投稿者: simple

支障なければ、URLを示してください。
 
こうしたサイトのなかには、スクレイピングを防止するために、
示された警告を返すところがあります。
openしてsendしただけですから、
コードに問題があるということより、
サーバー側の自衛措置だろうというのが、私の感触です。

回答
投稿日時: 19/07/13 00:09:46
投稿者: simple

余り「連続アクセス」を行うと、それに対する自衛措置をとることがある、
といったほうが適切だったかもしれません。

回答
投稿日時: 19/07/13 18:53:59
投稿者: simple

関連するかどうかわかりませんが、Tipsを書きます。

引用:
  'URL実行
  HttpReq.Open "GET", contentsURL
  HttpReq.send ★エラー発生個所
  
  Do While HttpReq.readyState < 4
    DoEvents
  Loop
とされていますが、
普通は、
  HttpReq.Open "GET", contentsURL ,False
とします。
そうすれば、サーバー側の処理が終わるまで、VBA側の処理の実行は
留保されます(非同期処理を Falseにする、つまり同期を取る)から、
  Do While HttpReq.readyState < 4
    DoEvents
  Loop
は不要です。

投稿日時: 19/07/13 22:25:40
投稿者: もみじっこ

 
simpl様
アドバイスいただきありがとうございます。
 
URLについて具体的に言うとgoogleで名所の名前+キーワードです
@「https://www.google.co.jp/search?q=東京タワー」を実行して一番上のURL取得
A「https://www.google.co.jp/search?q=東京タワー 住所」を実行して表示された住所を取得
B「https://www.google.co.jp/search?q=東京タワー 電話番号」を実行して表示された電話番号を取得
…というように検索しています
 
Tipsで教えていただいた事をひとまず修正してみます。

回答
投稿日時: 19/07/13 22:42:03
投稿者: simple

Googleですか、それなら、下記のスレッドが参考になると思います。
自衛措置をとっている可能性が高いです。
 
http://www.excel.studio-kazu.jp/kw/20190410094820.html

投稿日時: 19/07/14 22:25:55
投稿者: もみじっこ

恥ずかしながらスクレイピングという単語を初めて知りました。
結果的にそうなっていたようです。
 
処理の間にApplication.Waitを入れる事で解決しました
困っていたため大変助かりました、ありがとうございます!