【EXCEL VBA】AmazonのPAAPI5を使いたい

EXCEL VBAからPAAPI5を利用できる方法を紹介します。JavaやPHP、Pythonなどサンプルはよく見かけますが、VBAのサンプルが見つからなかったので今回作成しました。

前提条件

一番大事な部分です。ご自身のアカウントでProduct Advertising API 5.0 Scratchpadにて情報取得できるか確認をお願いします。Scratchpadで情報取得できない場合は、これから説明する内容は無意味となってしまいます。

事前準備

自前で全て作成するのは大変なので、色々と取り込んでいます。

.NET Framework 3.5のインストール

コマンドラインから「OptionalFeatures.exe」を起動してください。Windows の機能の有効化または無効化のダイアログが表示されます。.NET Framework 3.5(.NET 2.0および3.0を含む)にチェックをいれてOKを押してください。

参照設定

DictionaryとXMLHTML60クラスを使います。参照設定にてMicrosoft Scripting RuntimeとMicrosoft XML, v6.0をONにしておいてください。設定方法は以下記事を参考にしてください。

VBA-JSONのインストール

PAAPI5でのリクエストおよびレスポンスでJSONを利用します。コンバートおよびパースが必要となります。自前で準備するのは厳しいのでVBA-JSONを利用してます。インストール方法は以下記事を参考にしてください。

サンプルプログラム

Amazonから提供されているPHPのサンプルをベースに作成しました。ブックやシートに依存しないように作成していますご自身の利用目的に合わせて改造してもらえればと思います。

だらだら書いたため無駄な部分や汚い部分が色々と・・。少しずつ修正していきたいと思います。

まずはメインプログラムです。ThisWorkbookあたりに入れてもらえれば。アクセスキーなどはご自身の環境に合わせて修正してください。

Option Explicit

Const ACCESS_KEY = "********************"                       ' アクセスキー
Const SECRET_KEY = "****************************************"   ' シークレットキー
Const PARTNER_TAG = "**********"                                ' パートナータグ
Const SERVICE_NAME = "ProductAdvertisingAPI"
Const REGION = "us-west-2"
Const HOST = "webservices.amazon.co.jp"
Const URI_PATH = "/paapi5/searchitems"
Const REQUEST_METHOD = "POST"

Function Paapi() As String
    Dim payloadRoot As Dictionary, payloadResources As Collection
    Set payloadRoot = New Dictionary
    Set payloadResources = New Collection
    
    payloadRoot.Add "Keywords", "M590"      ' キーワードはM590
    With payloadResources                   ' 必要なリソースはカスタマイズください
        .Add "Images.Primary.Medium"
        .Add "ItemInfo.Title"
        .Add "Offers.Listings.Price"
    End With
    payloadRoot.Add "Resources", payloadResources
    payloadRoot.Add "PartnerTag", PARTNER_TAG
    payloadRoot.Add "PartnerType", "Associates"
    payloadRoot.Add "Marketplace", "www.amazon.co.jp"
    
    Dim payload As String
    payload = JsonConverter.ConvertToJson(payloadRoot)
    
    Dim paapi5 As AwsV4: Set paapi5 = New AwsV4
    paapi5.setAccessKey (ACCESS_KEY)
    paapi5.setSecretKey (SECRET_KEY)
    paapi5.setRegionName (REGION)
    paapi5.setServiceName (SERVICE_NAME)
    paapi5.setPath (URI_PATH)
    paapi5.setRequestMethod (REQUEST_METHOD)
    paapi5.setPayload (payload)
    
    Dim headers As Dictionary
    Set headers = paapi5.getHeaders()
    
    Dim headerString As String
    headerString = ""

    Dim key As Variant
    For Each key In headers
        headerString = headerString & key & ": " & headers.Item(key) & vbCrLf
    Next

    Dim httpReq As XMLHTTP60
    Set httpReq = New XMLHTTP60

    httpReq.Open "POST", "https://" & HOST & URI_PATH
    httpReq.setRequestHeader "content-encoding", headers("content-encoding")
    httpReq.setRequestHeader "content-type", headers("content-type")
    httpReq.setRequestHeader "host", HOST
    httpReq.setRequestHeader "x-amz-target", headers("x-amz-target")
    httpReq.setRequestHeader "x-amz-date", headers("x-amz-date")
    httpReq.setRequestHeader "Authorization", headers("Authorization")

    httpReq.send payload

    Do While httpReq.readyState < 4
        DoEvents
    Loop

    Debug.Print httpReq.responseText
End Function

クラスモジュールです。クラスモジュールの挿入から追加してください。クラス名はAwsV4としてください。

Option Explicit

Private accessKey As String
Private secretKey As String
Private path As String
Private regionName As String
Private serviceName As String
Private httpMethodName As String
Private queryParametes As Dictionary
Private awsHeaders As Dictionary
Private payload As String
Private HMACAlgorithm As String
Private aws4Request As String
Private strSignedHeader As String
Private xAmzDate As String
Private currentDate As String

Private Sub Class_Initialize()
    Set queryParametes = New Dictionary
    Set awsHeaders = New Dictionary
    HMACAlgorithm = "AWS4-HMAC-SHA256"
    aws4Request = "aws4_request"
    
    Set awsHeaders = New Dictionary
    awsHeaders.Add "content-encoding", "amz-1.0"
    awsHeaders.Add "content-type", "application/json; charset=utf-8"
    awsHeaders.Add "host", "webservices.amazon.co.jp"
    awsHeaders.Add "x-amz-target", "com.amazon.paapi5.v1.ProductAdvertisingAPIv1.SearchItems"
    
    xAmzDate = getDate
    currentDate = getTimeStamp
End Sub

Public Sub setAccessKey(paccessKey)
    accessKey = paccessKey
End Sub

Public Sub setSecretKey(psecretKey)
    secretKey = psecretKey
End Sub

Public Sub setRegionName(pregionName)
    regionName = pregionName
End Sub

Public Sub setServiceName(pserviceName)
    serviceName = pserviceName
End Sub

Public Sub setPath(ppath)
    path = ppath
End Sub

Public Sub setPayload(ppayload)
    payload = ppayload
End Sub

Public Sub setRequestMethod(prequestMethod)
    httpMethodName = prequestMethod
End Sub

Private Function prepareCanonicalRequest() As String
    Dim canonicalURL As String
    canonicalURL = ""
    canonicalURL = canonicalURL & httpMethodName & vbLf
    canonicalURL = canonicalURL & path & vbLf & vbLf
    Dim signedHeaders As String
    signedHeaders = ""
    Dim key As Variant
    For Each key In awsHeaders
        signedHeaders = signedHeaders & key & ";"
        canonicalURL = canonicalURL & key & ":" & awsHeaders.Item(key) & vbLf
    Next
    canonicalURL = canonicalURL & vbLf
    strSignedHeader = Left(signedHeaders, Len(signedHeaders) - 1)
    canonicalURL = canonicalURL & strSignedHeader & vbLf
    canonicalURL = canonicalURL & generateHex(payload)
    prepareCanonicalRequest = canonicalURL
End Function

Private Function prepareStringToSign(canonicalURL As String) As String
    Dim stringToSign  As String
    stringToSign = ""
    stringToSign = stringToSign & HMACAlgorithm & vbLf
    stringToSign = stringToSign & xAmzDate & vbLf
    stringToSign = stringToSign & currentDate & "/" & regionName & "/" & serviceName & "/" & aws4Request & vbLf
    stringToSign = stringToSign & generateHex(canonicalURL)
    prepareStringToSign = stringToSign
End Function

Private Function calculateSignature(stringToSign As String) As String
    Dim signatureKey() As Byte
    signatureKey = getSignatureKey(secretKey, currentDate, regionName, serviceName)
    
    Dim signature() As Byte
    signature = hashHmac2(stringToSign, signatureKey)
    
    calculateSignature = LCase(btos(signature))
End Function

Public Function getHeaders()
    awsHeaders.Add "x-amz-date", xAmzDate
    kSort awsHeaders
    
    ' Step 1: CREATE A CANONICAL REQUEST
    Dim canonicalURL As String
    canonicalURL = prepareCanonicalRequest()
    
    ' Step 2: CREATE THE STRING TO SIGN
    Dim stringToSign As String
    stringToSign = prepareStringToSign(canonicalURL)
    
    ' Step 3: CALCULATE THE SIGNATURE
    Dim signature  As String
    signature = calculateSignature(stringToSign)
    
    ' Step 4: CALCULATE AUTHORIZATION HEADER
    If signature <> "" Then
        awsHeaders.Add "Authorization", buildAuthorizationString(signature)
        Set getHeaders = awsHeaders
    End If
End Function
    
Private Function buildAuthorizationString(strSignature)
    buildAuthorizationString = HMACAlgorithm & " Credential=" & accessKey & "/" & getTimeStamp() & "/" & regionName & "/" & serviceName & "/" & aws4Request & ",SignedHeaders=" & strSignedHeader & ",Signature=" & strSignature
End Function

Private Function getSignatureKey(key As String, cddate As String, regionName As String, serviceName As String) As Byte()
    Dim objUTF8: Set objUTF8 = CreateObject("System.Text.UTF8Encoding")
    
    Dim kSecret As String: kSecret = "AWS4" & key
    Dim kbytes() As Byte: kbytes = objUTF8.Getbytes_4(kSecret)
    
    
    Dim kDate() As Byte: kDate = hashHmac2(cddate, kbytes)
    Dim kRegion() As Byte: kRegion = hashHmac2(regionName, kDate)
    Dim kService() As Byte: kService = hashHmac2(serviceName, kRegion)
    Dim kSigning() As Byte: kSigning = hashHmac2(aws4Request, kService)
    
    getSignatureKey = kSigning

End Function

Public Function generateHex(str As String) As String
    Dim objSHA256: Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    Dim objUTF8: Set objUTF8 = CreateObject("System.Text.UTF8Encoding")

    Dim bytes() As Byte: bytes = objUTF8.Getbytes_4(str)
    Dim hash() As Byte: hash = objSHA256.ComputeHash_2((bytes))
 
    Dim i As Integer
    Dim tmp
    For i = 1 To UBound(hash) + 1
        tmp = tmp & Right("0" & Hex(AscB(MidB(hash, i, 1))), 2)
    Next i
 
    generateHex = LCase(tmp)
    Set objSHA256 = Nothing
    Set objUTF8 = Nothing
End Function

' NET Framewrok3.5 が必要 https://paso-kake.com/it/windows11/12969/
Public Function hashHmac2(str As String, ByRef key() As Byte) As Byte()
    Dim objSHA256: Set objSHA256 = CreateObject("System.Security.Cryptography.HMACSHA256")
    Dim objUTF8: Set objUTF8 = CreateObject("System.Text.UTF8Encoding")

    Dim strbytes() As Byte: strbytes = objUTF8.Getbytes_4(str)
    
    objSHA256.key = key
    
    Dim hash() As Byte: hash = objSHA256.ComputeHash_2(strbytes)
    
    Set objSHA256 = Nothing
    Set objUTF8 = Nothing
    
    hashHmac2 = hash
End Function

Private Function getTimeStamp() As String
    Dim wmDate As Object
    Set wmDate = CreateObject("WbemScripting.SWbemDateTime")
    wmDate.SetVarDate Now()
    getTimeStamp = Format(wmDate.GetVarDate(False), "yyyymmdd")
End Function

Private Function getDate() As String
    Dim wmDate As Object
    Set wmDate = CreateObject("WbemScripting.SWbemDateTime")
    wmDate.SetVarDate Now()
    getDate = Format(wmDate.GetVarDate(False), "yyyymmddThhnnssZ")
End Function

Private Function btos(bytes() As Byte) As String
    Dim i As Integer
    Dim tmp
    For i = 1 To UBound(bytes) + 1
        tmp = tmp & Right("0" & Hex(AscB(MidB(bytes, i, 1))), 2)
    Next i
    btos = tmp
End Function

Private Sub kSort(ByRef header As Dictionary)
    Dim list As Object
    Dim arrKeys As Variant
    Dim arrSort As Variant
    Dim varItem As Variant
    Dim i As Long
    
    arrKeys = header.Keys
    Set list = CreateObject("System.Collections.ArrayList")
    For i = LBound(arrKeys) To UBound(arrKeys)
        list.Add arrKeys(i)
    Next
    list.Sort
    arrSort = list.ToArray
    
    For i = LBound(arrSort) To UBound(arrSort)
        varItem = header.Item(arrSort(i))
        header.Remove arrSort(i)
        header.Add arrSort(i), varItem
    Next
End Sub