esp@cenet(Espacenet)が公開しているRESTfulなWeb APIを利用して、PDF公報をダウンロードするマクロを書いてみました。
引数として公開番号とPDFファイルの保存先フォルダのパスを渡すと、指定したフォルダに公開番号名のフォルダを作成し、その中にPDFファイルをダウンロード・保存するマクロです。
(処理終了後はPDFファイルを保存したフォルダを自動的に開きます。)
Option Explicit Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Public Sub Sample() GetPatentPDF "JP10000002", "C:\Test" End Sub Public Sub GetPatentPDF(ByVal PN As String, ByVal SaveFolderPath As String) 'PN:公開番号 , SaveFolderPath:PDFファイルの保存先フォルダのパス Dim Link As String Dim Pages As String Dim ImgUrl As String Dim d As Object Dim n As Object Dim i As Long Const url As String = "http://ops.epo.org/2.6.2/rest-services/" Set d = Nothing: Link = "": Pages = "" '初期化 On Error Resume Next With CreateObject("MSXML2.XMLHTTP") .Open "GET", url & "published-data/publication/epodoc/" & PN & "/images", False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .Send If .Status <> 200 Then MsgBox "処理が失敗しました。" & vbCrLf & "ResponseCode:" & .Status, vbCritical + vbSystemModal Exit Sub Else Set d = .responseXML End If End With On Error GoTo 0 If Not d Is Nothing Then For Each n In d.SelectNodes("/ops:world-patent-data/ops:document-inquiry/ops:inquiry-result/ops:document-instance") If InStr(LCase$(n.getAttribute("desc")), "full") Then Link = n.getAttribute("link") Pages = n.getAttribute("number-of-pages") Exit For End If Next If Len(Pages) > 0 Then '保存先フォルダ準備 If Right$(SaveFolderPath, 1) <> Application.PathSeparator Then SaveFolderPath = SaveFolderPath & Application.PathSeparator SaveFolderPath = SaveFolderPath & PN With CreateObject("Scripting.FileSystemObject") If .FolderExists(SaveFolderPath) Then .DeleteFolder SaveFolderPath .CreateFolder SaveFolderPath End With For i = 1 To CLng(Pages) ImgUrl = url & Link & ".pdf?Range=" & i 'pdf決め打ち URLDownloadToFile 0&, ImgUrl, SaveFolderPath & Application.PathSeparator & PN & "-" & CStr(i) & ".pdf", 0&, 0& Next CreateObject("Shell.Application").Open SaveFolderPath & Application.PathSeparator End If End If End Sub
上記コードはAPIのごく一部の機能しか使っていない単純なマクロで、エラー処理もかなり手を抜いています。
より細やかな制御を必要とする場合やその他の検索機能を実装する場合は、下記WebページからダウンロードできるAPIの資料(Open Patent Services RESTful Web Services Reference Guide)をご参照ください。
・Open Patent Services (OPS)
http://www.epo.org/searching/free/ops.html
素晴らしいコードを公開して下さり、ありがとうございます。