「amazonの情報を署名付きで取得するサンプル・VBAコード（EXCEL図書管理）」

戻る

EXCEL図書管理.xlsでは、新規図書の登録の際に、amazonから情報を取得していました。
AWSの仕様が変わり、2009/8月からは署名付きでないとアクセスできなくなりました。署名付きのVBAコードが、MASさんのホームページでサンプルとして掲載されていましたので、大いに参考にさせていただき、EXCEL図書管理のVBAコードを修正できたように思いますので、掲載します。「思います」の意味は、余りテストしていないということです。8冊10桁ISBN、13桁ISBNで情報取得は出来ました。
なお、MASさんのホームページのサンプルにもありますように、DLLが必要です。EXCEL図書管理と同じフォルダーにsign.dllを保管しておいてください。

利用にあたっては、AWS利用規約をよくお読みいただくことと、AWSAccessKeyIdとSecretKeyを利用者が各自取得しVBA内のコードをご自身のkeyに書き換える必要があります。　なお、SecretKeyは他人に知らせない・知られてはいけないとのことです。
VBA保存で、表示パスワードを設定しての運用か、他者に当ブックを渡す場合はパスワードを消してから渡すようにするのが好ましいと思われます。
xlのパスワードは時間を掛ければ解析されるようです。できるだけ長いものおよび英数字記号が入ったものが好ましいと言われています。
2007年現在で、16桁で解析2カ月と言われています。ですので、20桁もしくは30桁ぐらいが妥当でしょうか（ぉ
長い文章をローマ字入力して作ると何かと覚えやすいかもしれません。　<ご参考>　pass解析　password解析速度一覧
例：mynamaeisneko_adgopu:jlakjrgepjah;ohe098345h3; （汗

keyの取得は、こちら。　※AWSのアカウントを取得していない場合は、まずAWSアカウントの取得から行います。
key取得の説明は、こちらにあります。

EXCEL図書管理.xlsでは、「図書の新規登録」の一括処理シート上のボタンにマクロを関連づけているのと、
保守管理フォームのなかの、新規図書の登録タブ上のボタンに関連づけているものがあります。

現状のxlsのVBA該当モジュールを入れ替えると、動作すると思われる。
なお、モジュールのそれぞれのマクロ名は変更していない。

(2014/4/13 新しいコードと入れ替えしました。)

Option Explicit
Public Declare Sub UrlSign Lib "Sign.dll" (ByVal Url As String, ByVal SignedUrl As String, ByVal SecretKey As String)


Sub Amazon2Sheet()
' このプロシージャ＝図書の新規シート上のボタン
' http://www.microstory.org/gakusi/wiki/ExcelAWSMemo.html 参照。
'　GetBookInfoFromAmazon()をengiが変更（説明追加）したものです。
'　http://www2u.biglobe.ne.jp/~MAS/hoka/excelamazon.html
'　AWS署名付きでのアクセス方法は、MASさんのページ参照　：同じフォルダにSign.dll要。
'　コメントは、基本コメント行の上の構文について付けています。

'　「図書の新規登録」の一括処理シートにて利用。

Dim Res
Res = MsgBox("ISBN番号を元に、amazon.co.jpから、図書情報を取得します。" & vbCrLf & _
"インターネットに接続できている必要があります。" & vbCrLf & _
"B列〜G列までのセルは上書きされます。", vbOKCancel, "amazon.webｻｰﾋﾞｽの利用")
If Res = vbCancel Then Exit Sub

Dim Url As String
Dim xmldata As Object
Dim Author As Object
Dim i As Integer
Dim j As Long
Dim k As Long
Dim Atai As Long
Dim ItemAttributes As Object
Dim Asin As String
Dim rowIndex As Integer
Dim item As Object
Dim SignedUrl As String
Dim keyid As String '　<--追加(engi)
Dim SecretKey As String

Application.ScreenUpdating = False
Dim afo As String

afo = "******-22" '< --自身のアソシエイト番号を入れる｡
keyid = "***************************" '　<--　変更(自身のKEYIDを入れる。)
SecretKey = "*****************************************" '　< --自身のSecretkeyを入れる｡

'　↑のkey・IDが未入力なら、処理中止：エラー対処 2013/9/21
If Mid(afo, 1, 1) = "*" Or Mid(keyid, 1, 1) = "*" Or Mid(SecretKey, 1, 1) = "*" Then
MsgBox "Amazonのキーが登録されていません。" & vbCrLf & "処理を中止します。", vbExclamation + vbOKOnly, "エラー"
Exit Sub
End If

'　動作を確認したら、プロジェクトウインドウの標準モジュール＝Amazon2excel上で右クリックして、
'　保護タブ〜プロジェクト表示用のパスワードを入力すること。
'　パスワードの文字の長さは13ケタ以上〜長ければ長いほどよい〜にすること。
ChDrive ActiveWorkbook.path
ChDir ActiveWorkbook.path

rowIndex = 10 '　10行目を固定行とする。

While ActiveSheet.Cells(rowIndex, 1) <> ""
'　A5セルから下方向に連続して処理をする。A列のセル値が空白の場合は処理を終了する。

Asin = ActiveSheet.Cells(rowIndex, 1).Value

Url = "http://webservices.amazon.co.jp/onca/xml?Service=AWSECommerceService&AWSAccessKeyId=" & keyid & "&Operation=ItemLookup&IdType=ISBN&SearchIndex=Books&ResponseGroup=Medium&Version=2009-03-31&ItemId=" & Asin & "&AssociateTag=" & afo

' 署名をつける
SignedUrl = String(Len(Url) + 100, vbNullChar)
Call UrlSign(Url, SignedUrl, SecretKey)
SignedUrl = Left(SignedUrl, InStr(SignedUrl, vbNullChar) - 1)

Set xmldata = CreateObject("Microsoft.XMLDOM")
xmldata.async = False
xmldata.Load SignedUrl
Set ItemAttributes = xmldata.SelectSingleNode("ItemLookupResponse/Items/Item/ItemAttributes")

If Not ItemAttributes Is Nothing Then '取得情報があれば、
'著者
Dim authorText As String
authorText = ""
Set Author = ItemAttributes.selectNodes("Author")
'　変数itemAttributesの中のAuthor項目を選択し、その値をauthor変数に代入する。
'　↓は著者項目のブランク対応か？
For i = 0 To Author.Length - 1
authorText = authorText & Author(i).Text
If i <> Author.Length - 1 Then
authorText = authorText & "，"
End If
Next
ActiveSheet.Cells(rowIndex, 3) = authorText

'タイトル
ActiveSheet.Cells(rowIndex, 2) = ItemAttributes.SelectSingleNode("Title").Text
'「.selectSingleNode」
'出版社
ActiveSheet.Cells(rowIndex, 4) = ItemAttributes.SelectSingleNode("Publisher").Text

'値段　（engiは使わないので,コメントアウトした。）
ActiveSheet.Cells(rowIndex, 7) = ItemAttributes.SelectSingleNode("ListPrice/Amount").Text
'　入荷日=I1セル値を代入する。
If ActiveSheet.Cells(rowIndex, 2) <> "" Then ActiveSheet.Cells(rowIndex, 6) = Format(Range("i1").Value, "yyyy/mm/dd")

Else
'　ActiveSheet.Cells(rowIndex, 2) = "●●該当の情報はありません。●●"
'　もし、該当したISBN番号＝asin値がない場合の処理を入れるかどうか。
End If

次へ:
rowIndex = rowIndex + 1
Set xmldata = Nothing
'　amazon.co.jpへのWEBサービスへは、1秒間隔を空けろとのことなので、ウエイト入れる。
'　下記timevalueを0:00:01では場合によりamazonからエラーになるので、0:00:02とした。
'　エラーが出る場合、0:00:03など値を大きくする。
Excel.Application.Wait (Now + TimeValue("0:00:01"))
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Wend

MsgBox "amazonから図書データを取得完了。B列〜が空白のものは該当データが見つからなかったものです。", , "amazon2:Done"


End Sub

Sub Amazon2excelform()

' http://www.microstory.org/gakusi/wiki/ExcelAWSMemo.html から転載。
'　GetBookInfoFromAmazon()をengiが変更（説明追加）したものです。
'　http://www2u.biglobe.ne.jp/~MAS/hoka/excelamazon.html
'　MASさんのページ参照
'　コメントは、基本コメント行の上の構文について付けています。

'　Userform5の新規図書の登録タブにて、使用している。

Dim Url As String
Dim xmldata As Object
Dim Author As Object
Dim i As Integer
Dim ItemAttributes As Object
Dim Asin As String
Dim rowIndex As Integer
Dim item As Object
Dim Syuppan As String
Dim SignedUrl As String
Dim keyid As String '　<--追加(engi)
Dim SecretKey As String
Dim afo As String

' フォーム5内で入力された値を元に、amazonから情報を取得する。
Application.ScreenUpdating = False
Worksheets("work").Activate

afo = "**********-22" '
keyid = "********************" '　<--　変更(自身のKEYIDを入れる。)
SecretKey = "**************************************" '　< --自身のSecretkeyを入れる｡

If Mid(keyid, 1, 1) = "*" Then
MsgBox "Amazonのkeyidが定義されていません。" _
& vbCrLf & vbCrLf & "定義してから再度、実行して下さい。", vbOKOnly + vbExclamation, "amazon2:エラー"
Exit Sub
End If
If Mid(SecretKey, 1, 1) = "*" Then
MsgBox "AmazonのSecretKeyが定義されていません。" _
& vbCrLf & vbCrLf & "定義してから再度、実行して下さい。", vbOKOnly + vbExclamation, "amazon2:エラー"
Exit Sub
End If

ChDrive ActiveWorkbook.path
ChDir ActiveWorkbook.path

Asin = UserForm5.TextBox5.Value

Url = "http://webservices.amazon.co.jp/onca/xml?Service=AWSECommerceService&AWSAccessKeyId=" & keyid & "&Operation=ItemLookup&IdType=ISBN&SearchIndex=Books&ResponseGroup=Medium&Version=2009-03-31&ItemId=" & Asin & "&AssociateTag=" & afo

' 署名をつける
SignedUrl = String(Len(Url) + 100, vbNullChar)
Call UrlSign(Url, SignedUrl, SecretKey)
SignedUrl = Left(SignedUrl, InStr(SignedUrl, vbNullChar) - 1)
' API実行
Set xmldata = CreateObject("Microsoft.XMLDOM")
xmldata.async = False
'　falseを指定して同期読み込みとしておく必要がある。
xmldata.Load SignedUrl
Set ItemAttributes = xmldata.SelectSingleNode("ItemLookupResponse/Items/Item/ItemAttributes")

If Not ItemAttributes Is Nothing Then '取得情報があれば、
'著者
Dim authorText As String
authorText = ""
Set Author = ItemAttributes.selectNodes("Author")

For i = 0 To Author.Length - 1
authorText = authorText & Author(i).Text
If i <> Author.Length - 1 Then
authorText = authorText & "，"
End If
Next

UserForm5.TextBox7.Value = authorText

'タイトル
UserForm5.TextBox6.Value = ItemAttributes.SelectSingleNode("Title").Text
'「.selectSingleNode」
'出版社 : comboboxは編集可にしておくこと。（userform5のactivateで定義している）
Syuppan = ItemAttributes.SelectSingleNode("Publisher").Text
UserForm5.ComboBox1.Value = Syuppan
'値段
UserForm5.TextBox11.Value = ItemAttributes.SelectSingleNode("ListPrice/Amount").Text

End If

'　amazon.co.jpへのWEBサービスへは、1秒間隔以上を空けろとのことなので、ウエイト入れる。
Excel.Application.Wait (Now + TimeValue("0:00:01"))
End Sub

Sub GetFromISBN_rakuten() '　最新の構文
'入力パラメーターなどは　http://webservice.rakuten.co.jp/api/booksbooksearch/

Dim xml, result As Object
Dim Url, status As String
Dim Taitoru, Sakusya, Syuppansya, Komento, Nedan As String
Dim isbn, DeveloperID As String
Dim i, j As Long

DeveloperID = "*****************************" '　★このIDがないと楽天WEBに接続できません。自身のIDを入れて下さい。

If Mid(DeveloperID, 1, 1) = "*" Then
MsgBox "楽天デベロッパーＩＤが定義されていません。" _
& vbCrLf & vbCrLf & "定義してから再度、実行して下さい。", vbOKOnly + vbExclamation, "amazon2:エラー"
Exit Sub
End If

Range("b4:e8").ClearContents

For i = 10 To 501
isbn = Range("a" & i).Value
If isbn = "" Then MsgBox " " & i & "行：データ無し。楽天WEBからのデータ取得の処理終了", , "amazon2:end": Exit Sub

Url = "http://api.rakuten.co.jp/rws/3.0/rest?" '変更
Url = Url & "developerId=" & DeveloperID
Url = Url & "&operation=BooksBookSearch"
Url = Url & "&version=2011-07-07" ' 変更
Url = Url & "&isbn=" & isbn

Set xml = CreateObject("Microsoft.XMLDOM")
xml.async = False
xml.Load (Url)

status = xml.SelectSingleNode("/Response/header:Header/Status").nodeTypedValue
If (status <> "Success") Then
If status = "NotFound" Then MsgBox "NotFound:検索結果が存在しない｡", , "amazon2:NotFound"
If status = "ServerError" Then MsgBox "ServerError:楽天ウェブサービス側のエラー｡", , "amazon2:error"
If status = "ClientError" Then MsgBox "ClientError:デベロッパーの入力に起因するエラー｡", , "amazon2:error"
If status = "Maintenance" Then MsgBox "Maintenance:メンテナンス｡", , "amazon2:error"

' MsgBox "楽天WEBデータベースに接続できませんでした。"
GoTo tugihe
End If

Set result = xml.SelectSingleNode("/Response/Body/booksBookSearch:BooksBookSearch/Items/Item")
Taitoru = result.SelectSingleNode("title").nodeTypedValue
Sakusya = result.SelectSingleNode("author").nodeTypedValue
Syuppansya = result.SelectSingleNode("publisherName").nodeTypedValue
Komento = result.SelectSingleNode("itemCaption").nodeTypedValue
Nedan = result.SelectSingleNode("itemPrice").nodeTypedValue

Range("b" & i) = Taitoru
Range("c" & i) = Sakusya
Range("d" & i) = Syuppansya
' Range("e" & i) = Komento
Range("g" & i) = Nedan

tugihe:
Excel.Application.Wait (Now + TimeValue("0:00:01"))
Next i

MsgBox "マクロ終了", , "amazon2:macro_end"

End Sub
Sub 新規登録シートクリア()
'　検索・データ取得する前に、入力されるセルをクリアする。
' Dim Atai
' Atai = MsgBox("取得データを貼り付けするセルをクリアします。B,C,D,G各列の10行から50行まで。", vbokcansel)
' If Atai = vbOK Then ' セル範囲をクリアする。

Application.ScreenUpdating = True

Sheets("図書の新規登録").Range("b10:d500").ClearContents
Sheets("図書の新規登録").Range("g10:g500").ClearContents

End Sub

戻る