Amazon Web Service を VBA で使う

gistfile1.bas

'------------------------------------------------------------------------------------------
' Amazon Web Service Access Module for VBA
'------------------------------------------------------------------------------------------

Option Explicit
Option Compare Database

' Amazon の Web サービスを使用するのに必要な認証キー
' 会員登録すると発行されます：http://www.amazon.co.jp/gp/feature.html/ref=amb_link_14390606_7/503-5734628-1617548?ie=UTF8&docId=451209
Public Const AmazonDevToken As String = ""

Public Type AWSResult
    Success As Boolean          ' 成否
    ErrorMessage As String      ' エラーメッセージ
    Isbn As String              ' ISBN
    Title As String             ' 書名
    Author As String            ' 著者
    Manufacturer As String      ' 出版社
    PublicationDate As String   ' 発行年月日
    NumberOfPages As String     ' ページ数
    Price As String             ' 価格
    Binding As String           ' 形態
End Type

Public Function GetAmazonInfo(ByVal Isbn As String) As AWSResult
    On Error GoTo ErrExit
    
    ' 戻り値
    Dim returnValue As AWSResult
    returnValue.Success = False
    returnValue.Isbn = Isbn
    
    ' ハイフン除去
    Isbn = Replace(Isbn, "-", vbNullString, , , vbBinaryCompare)
    
    ' 13桁のISBNの場合、10桁に計算し直す
    If Len(Isbn) = 13 Then
        Isbn = Isbn13ToIsbn10(Isbn)
    End If
    
    ' アクセス用URLを作成
    Dim requestUrl As String
    requestUrl = "http://webservices.amazon.co.jp/onca/xml?Service=AWSECommerceService" & _
                 "&SubscriptionId=" & AmazonDevToken & _
                 "&Operation=ItemLookup" & _
                 "&ItemId=" & Isbn & _
                 "&ResponseGroup=ItemAttributes"
    
    ' 結果取得
    Dim HTTP As Object
    Dim httpResText As String
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    HTTP.Open "GET", requestUrl, False
    HTTP.Send
    httpResText = HTTP.responseText
    Set HTTP = Nothing
    
    ' 結果のパース
    Dim startPos As Integer ' キャプチャ開始点
    
    ' エラーの有無を確認する
    startPos = InStr(1, httpResText, "<Error>", vbBinaryCompare)
    If startPos > 0 Then
        returnValue.ErrorMessage = GetTagText(httpResText, "Code", startPos)
        Debug.Print returnValue.ErrorMessage
        GoTo ErrExit
    End If
    
    ' ItemAttributes までとばす
    startPos = InStr(1, httpResText, "<ItemAttributes>", vbBinaryCompare)
    
    ' 各タグのデータを取得する
    returnValue.Title = GetTagText(httpResText, "Title", startPos)
    returnValue.Author = GetTagText(httpResText, "Author", startPos)
    returnValue.Manufacturer = GetTagText(httpResText, "Manufacturer", startPos)
    returnValue.PublicationDate = GetTagText(httpResText, "PublicationDate", startPos)
    returnValue.NumberOfPages = GetTagText(httpResText, "NumberOfPages", startPos)
    returnValue.Price = GetTagText(httpResText, "FormattedPrice", startPos)
    returnValue.Binding = GetTagText(httpResText, "Binding", startPos)
    
    returnValue.Success = True
    GetAmazonInfo = returnValue
    Exit Function
ErrExit:
    returnValue.Success = False
    GetAmazonInfo = returnValue
End Function

'------------------------------------------------------------------------------------------
' タグの間のテキストを取得します。検索文字列内に1種類のタグしかないことが前提
'------------------------------------------------------------------------------------------

Function GetTagText(ByVal text As String, ByVal tag As String, Optional ByVal start As Integer = 1)
    Dim capStart As Integer
    Dim capEnd As Integer
    
    capStart = start
    
    capStart = InStr(capStart, text, "<" & tag & ">", vbBinaryCompare) + Len("<" & tag & ">")
    capEnd = InStr(capStart, text, "</" & tag & ">", vbBinaryCompare)
    GetTagText = Mid(text, capStart, capEnd - capStart)
End Function

'------------------------------------------------------------------------------------------
' Amazon の検索ID として使用するため、ISBN13 を ISBN10 へ変換します
' 979 の番号空間が使われ始めたらこれは使えない。Amazonの対応待ち。
'------------------------------------------------------------------------------------------

Private Function Isbn13ToIsbn10(ByVal inValue As String) As String
    
    ' 頭三桁(978)とチェックデジットを除去します
    inValue = Mid(inValue, 4, 9)
    
    ' [チェックデジット計算方法]
    '(1) 10桁コードの各桁の桁数(d)と値(Vd)の積の合計を求める（ただし d > 1）。
    '    V10×10 ＋ V9×9 ＋ V8×8 ＋ … ＋ V2×2
    '(2) チェックディジット ＝ 11 －（(1)の答を 11 で割った剰余） となる。
    '    ただし、求めた数字が 10 の場合は X とし、11 の場合は 0 とする。
    
    ' (1) の計算
    Dim vT As Integer   ' (1) の計算結果
    Dim v  As Integer   ' 各桁の値
    Dim d  As Integer   ' 桁
    
    For d = 10 To 2 Step -1
        v = CInt(Mid(inValue, 10 - d + 1, 1))
        vT = vT + v * d
    Next d
    
    ' (2) の計算
    Dim digitBase As Integer ' (1) の計算結果
    Dim checkDigit As String ' チェックデジット

    digitBase = 11 - (vT Mod 11)
    If digitBase = 11 Then
        checkDigit = 0
    ElseIf digitBase = 10 Then
        checkDigit = "X"
    Else
        checkDigit = digitBase
    End If
    
    Isbn13ToIsbn10 = inValue & checkDigit
End Function