Office関連

esp@cenetが公開しているPDF公報をダウンロードするVBAマクロ

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

Outlookで返信作成時に件名に自動的に付加される「RE:」を「Re:」にするOutlookマクロ前のページ

Windows 8 Release PreviewにはMicrosoft Security Essentialsをインストールできない?次のページ

関連記事

  1. Office関連

    [リボン・カスタマイズ]dropDown要素の初期項目を指定する。

    MSDN フォーラムに「リボン:ドロップダウンリストにlabel初期値…

  2. Office関連

    Excelのアイデア機能でグラフやピボットグラフを一発作成

    Insider版のExcelに「アイデア」機能が追加されました。…

  3. Windows 10

    【2017年1月版】Microsoft Edgeを操作するVBAマクロ(DOM編)

    2021/10/1 追記:本記事は公開されてから大分時間が経ってお…

  4. Office関連

    外部アプリケーションのコンボボックスの内容を取得するVBAマクロのサンプル

    Q&Aサイトに下記質問がありました。(この質問も何となく似たような…

  5. Office関連

    ルビ(ふりがな)を一括設定するWordマクロ(改良版)

    これまで当ブログではルビを設定するWordマクロについて、いくつか記事…

  6. Office関連

    [Excel Services ECMAScript]タイマーでグラフを描画する。

    タイマーで特定のセルの値を増やしていき、それに合わせてグラフを描画して…

コメント

    • くれよん
    • 2015年 3月 14日 1:31pm

    素晴らしいコードを公開して下さり、ありがとうございます。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP