Amazonをクローリングするサンプル

　Amazonが指定した方法以外で、AmazonのWebサイトをクローリングすることはできません。

　AmazonのWebサイトの利用規約にもそのように記載されているようですし、それ以外にも、Amazonの商品紹介ページのデザインは、細かな部分で頻繁に修正されてしまうようで、クローリングするプログラムをその都度書き換えなくてはなりません。

　実際、これから紹介するソースコードは、数年前ならAmazonのWebサイトから、書籍のISBNコードを予め設定しておくだけで、そのISBNコードに該当する書籍の情報を収集することができるプログラムのソースコードでした。エクセルマクロで作成したもので、クローリングにはInternet Explorerを使用しています。すでにInternet ExplorerはMicrosoftのサポート対象外となっており、セキュリティ的にも問題があるブラウザです。

Option Explicit

'==============================
' Win32API定義
'==============================
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)

'==============================
' 列挙体定義
'==============================
Private Enum ColumnIndex
    ISBN10 = 1
    ISBN13 = 2
    BookName = 3
    Author = 4
    PubDate = 5
    BookSize = 6
    PageNum = 7
    Memo = 8
End Enum

'==============================
' 定数定義
'==============================
'読み込み開始行
Private Const START_ROW As Long = 3

'********************************************************************************
' 関数名：Scraping()
' 概要　：Amazonサイトをスクレイピング
' 引数　：なし
' 戻り値：なし
'********************************************************************************
Public Sub Scraping()
    Const START_INFO As String = "登録情報"
    Const END_INFO As String = "</ul>"
    Const SEPARATE_CHAR As String = "</li>"

    '実行確認メッセージ
    If (MsgBox("データ取得を開始します。" & vbCrLf & "よろしいですか？", vbQuestion + vbYesNo + vbDefaultButton2) <> vbYes) Then
        Exit Sub
    End If

On Error Resume Next

    Dim row As Long
    row = START_ROW - 1

    Do
Continue:
        row = row + 1

        'ISBN-10を取得
        Dim ISBN10 As String
        ISBN10 = CStr(ActiveSheet.Cells(row, ColumnIndex.ISBN10).Value)

        '取得できない場合は処理を抜ける
        If (ISBN10 = "") Then
            Exit Do
        End If

        '書籍名を取得
        Dim BookName As String
        BookName = CStr(ActiveSheet.Cells(row, ColumnIndex.BookName).Value)

        If (ActiveSheet.chkSkip.Value) And (BookName <> "") Then
            '書籍名がすでに入っている場合は次のデータ
            GoTo Continue
        End If

        'Internet Explorerのインスタンスを生成
        '（Internet Explorerのインスタンスを使いまわすと、正常に動作しない）
        Dim ie As Object
        Set ie = CreateObject("InternetExplorer.Application")
        If (Err.Number <> 0) Then
            '必ず1回ごとに終了させる
            ie.Quit
            Err.Clear
            GoTo Continue
        End If

        'スクレイピングはバッググラウンドで行う
        ie.Visible = False

        'スクレイピング対象のURL
        Dim url As String
        url = "https://www.amazon.co.jp/dp/" & ISBN10

        'URL読み込み
        Call ie.Navigate(url)
        If (Err.Number <> 0) Then
            '必ず1回ごとに終了させる
            ie.Quit
            Err.Clear
            GoTo Continue
        End If
        Do
            If (ie.Busy = False) Then
                Exit Do
            End If
            Sleep 500
        Loop

        'HTML取得
        Dim html As String
        html = htmlDecode(ie.Document.Body.InnerHtml)
        If (Err.Number <> 0) Then
            '必ず1回ごとに終了させる
            ie.Quit
            Err.Clear
            GoTo Continue
        End If

        '読み込み開始位置取得
        Dim nSt As Long
        nSt = InStr(1, html, START_INFO)

        '読み込み開始位置が取得できない場合
        If (nSt < 0) Then
            ActiveSheet.Cells(row, ColumnIndex.BookName).Value = "（不明）"
            GoTo Continue

        '読み込み開始位置が取得できた場合
        Else
            '読み込み終了位置取得
            Dim nEd As Long
            nEd = InStr(nSt, html, END_INFO)

            '本情報を取得
            Dim s As String
            s = Mid(html, nSt, nEd - nSt)
            s = Replace(s, vbCr, "")
            s = Replace(s, vbLf, "")

            '古い紹介ページには「言語」がない
            Dim r As Integer
            If (InStr(1, s, "言語:") < 1) Then
                r = -1
            End If

            '</li>で分割
            Dim info As Variant
            info = Split(s, SEPARATE_CHAR)

            'Book情報をエクセルに転記
            ActiveSheet.Cells(row, ColumnIndex.ISBN13).Value = GetValue(info(3))    'ISBN-13
            ActiveSheet.Cells(row, ColumnIndex.BookName).Value = GetBookName(html)  '書名
            ActiveSheet.Cells(row, ColumnIndex.Author).Value = GetAuthor(html)      '著者名
            ActiveSheet.Cells(row, ColumnIndex.PubDate).Value = GetValue(info(0))   '発刊日
            ActiveSheet.Cells(row, ColumnIndex.BookSize).Value = GetValue(info(6))  '判型
            ActiveSheet.Cells(row, ColumnIndex.PageNum).Value = GetValue(info(1))   'ページ数
            ActiveSheet.Cells(row, ColumnIndex.Memo).Value = GetMemo(html)          '概要
        End If

        '必ず1回ごとに終了させる
        ie.Quit
    Loop

    '完了メッセージ
    Call MsgBox("完了しました。", vbInformation + vbOKOnly)

End Sub

'********************************************************************************
' 関数名：GetValue()
' 概要　：タグ付きデータから値に該当する部分のみ取得
' 引数　：[s]...タグ付きデータ
' 戻り値：値に該当する部分の文字列
'********************************************************************************
Private Function GetValue(ByVal s As String) As String
    Const ST_CHAR As String = "</span><span>"
    Const ED_CHAR As String = "</span></span>"

    Dim iPosSt As Long
    iPosSt = InStr(1, s, ST_CHAR)
    If (iPosSt < 1) Then
        GetValue = "（不明）"
    Else
        Dim iPosEd As Long
        iPosEd = InStr(1, s, ED_CHAR)

        GetValue = Mid(s, iPosSt + Len(ST_CHAR), iPosEd - iPosSt - Len(ST_CHAR))
    End If
End Function

'********************************************************************************
' 関数名：GetAuthor()
' 概要　：著者を取得
' 引数　：[html]...HTML
' 戻り値：著者に該当する部分の文字列
'********************************************************************************
Private Function GetAuthor(ByVal html As String) As String
    Const JDG_CHAR As String = "contributorNameID"

    Dim iPos As Long
    iPos = InStr(1, html, JDG_CHAR)

    If (iPos < 1) Then
        GetAuthor = "（不明）"
    Else
        Dim nSt As Long
        nSt = InStr(iPos, html, ">") + 1
        Dim nEd As Long
        nEd = InStr(nSt, html, "<")

        Dim s As String
        s = Mid(html, nSt, nEd - nSt)

        GetAuthor = s
    End If
End Function

'********************************************************************************
' 関数名：GetBookName()
' 概要　：書名を取得
' 引数　：[html]...HTML
' 戻り値：書名に該当する部分の文字列
'********************************************************************************
Private Function GetBookName(ByVal html As String) As String
    Const JDG_CHAR As String = "titleblock_feature_div"

    Dim iPos As Long
    iPos = InStr(1, html, JDG_CHAR)

    If (iPos < 1) Then
        GetBookName = ""
    Else
        Dim nSt As Long
        nSt = InStr(iPos, html, "productTitle") + Len("productTitle") + 2
        Dim nEd As Long
        nEd = InStr(nSt, html, "</span>")

        Dim s As String
        s = Mid(html, nSt, nEd - nSt)

        GetBookName = s
    End If
End Function

'********************************************************************************
' 関数名：GetMemo()
' 概要　：概要を取得
' 引数　：[html]...HTML
' 戻り値：概要に該当する部分の文字列
'********************************************************************************
Private Function GetMemo(ByVal html As String) As String
    Const JDG_CHAR As String = "a-section a-spacing-small a-padding-small"

    Dim iPos As Long
    iPos = InStr(1, html, JDG_CHAR)

    If (iPos < 1) Then
        GetMemo = ""
    Else
        Dim nSt As Long
        nSt = InStr(iPos, html, JDG_CHAR) + Len(JDG_CHAR) + 2

        Dim nEd As Long
        nEd = InStr(nSt, html, "</div>")

        Dim s As String
        s = Mid(html, nSt, nEd - nSt)

        GetMemo = s
    End If
End Function

'********************************************************************************
' 関数名：htmlDecode()
' 概要　：HTMLエンコードをデコード
' 引数　：[html]...HTML
' 戻り値：概要に該当する部分の文字列
'********************************************************************************
Private Function htmlDecode(ByVal html As String) As String

    'よく使われるHTML特殊文字コードを置換
    html = Replace(html, "&quot;", Chr(34)) '"
    html = Replace(html, "&lt;", Chr(60))   '<
    html = Replace(html, "&gt;", Chr(62))   '>
    html = Replace(html, "&amp;", Chr(38))  '&
    html = Replace(html, "&nbsp;", Chr(32)) ' (半角スペース)

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Pattern = "&#x(.+?);"              '抽出パターン
        .Global = True                      '全件マッチ：True／先頭マッチ：False
    End With

    Dim matches As Object
    Set matches = regEx.Execute(html)

    '正規表現パターンにマッチした数だけ繰り返し置換
    Dim match As Object
    For Each match In matches
        Dim strHex As String
        strHex = CLng("&H" & match.SubMatches(0))       '16進数→10進数へ変換

        Dim strUni As String
        strUni = ChrW(strHex)                           '10進数→マルチバイト文字へ変換

        html = Replace(html, match.Value, strUni)       '正規表現にマッチした箇所をマルチバイト文字列で置換
    Next

    '戻り値を返す
    htmlDecode = html

End Function

　このエクセルマクロを実装したエクセルマクロファイルは、添付しません。

　くどいようですが、AmazonのWebサイトへのクローリングは禁止されています。自己責任の上で、Amazon以外のクローリングが許可されているWebサイトに対し、またInternet Explorerが利用できる環境をご用意いただいて、上記ソースコードをご利用ください。