特許番号からJ-PlatPatにリンクするマクロ

Excelに記入した特許番号などからJ-PlatPatにリンクするマクロを作りました。 特許検索後に、特許の詳細を見たいときに使うことを想定しています。

このマクロでできること

1. Excelに記入した特許番号をクリックすると、特許庁のJ-PlatPatの検索結果を表示させる

2. 気になるキーワードをハイライトさせる

使い方

1. 下記のソースコードを、Visual Basic Editorで貼り付けます。

1. B3以下のセルに、検索したい特許番号を記入します。

2. C1のセルに、ハイライトさせたいキーワードを記入します。スペース区切りで複数のキーワードを記入可能です。 記入結果は下記のようなイメージです。

1. 検索結果を見たいセルをダブルクリックします。

2. J-PlatPatの検索結果が表示されます。下記の例では、「植物」と「偏光」にハイライトが付いているのが分かります。

キーワードにハイライトが付いているので見やすいですね！

ソースコード

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("B3:B10002")) Is Nothing Then Exit Sub
    Call patSearch
    Cancel = True
End Sub

Public Sub patSearch()
    
    Dim ie As InternetExplorer
    Dim myAdd As String
    Dim myFormula As String, myKeywords As String
    Dim myOpt(1) As String
    
    '条件設定
    myAdd = "https://www7.j-platpat.inpit.go.jp/tkk/tokujitsu/tkkt/TKKT_GM201_Top.action"

    myKeywords = Range("C1").Value
    myFormula = Selection.Value
    If myFormula = "" Then Exit Sub

    myOpt(0) = "05" '公報全文から
    
    '検索開始
    Call modFormula(myFormula, myOpt(1))
    
    Set ie = CreateObject("InternetExplorer.Application")

    Call myBrowserOpen(ie, myAdd)
        
    Call setCheckBox(ie)
    
    Call inputInfo(ie, 0, myOpt(0), myKeywords)
    Call inputInfo(ie, 1, myOpt(1), myFormula)

    Call doSearch(ie)

    Set ie = Nothing
    
End Sub

'特許庁の特許検索サイトを開く
Private Sub myBrowserOpen(ByRef ie As InternetExplorer, ByVal myAdd As String)
    
    ie.Visible = True
    ie.navigate myAdd
    Do While ie.Busy = True: DoEvents: Loop: Do While ie.document.readyState <> "complete": DoEvents: Loop

End Sub

'検索範囲設定
Private Sub setCheckBox(ByRef ie As InternetExplorer)
        
    ie.document.getElementById("bTmFCOMDTO.officialInfoList[1]").Checked = True '登録特許公報
    ie.document.getElementById("bTmFCOMDTO.officialInfoList[3]").Checked = True '公開実案
    ie.document.getElementById("bTmFCOMDTO.officialInfoList[4]").Checked = True '登録実案
    
End Sub

'検索式の修正
Private Sub modFormula(ByRef myFormula As String, ByRef myOpt As String)

    If InStr(myFormula, "-") = 0 Then
        myOpt = "35"    '登録番号
    Else
        myOpt = "31"    '公開番号
    End If
    
'    myOpt = "33"    '公告番号
'    myOpt = "38"    '公表番号

End Sub

'特許検索サイトに検索条件を入力する
Private Sub inputInfo(ByRef ie As InternetExplorer, ByVal myRow As Integer, ByVal myOpt As String, ByVal myStr As String)
    Dim myBox As String
    Dim myList As String
    
    myBox = "bunkenBango" & myRow
    myList = "searchForm_bTmFCOMDTO_searchItemList_" & myRow & "_"
    
    ie.document.all(myBox).Focus
    ie.document.all(myBox).Value = myStr
    ie.document.all(myList).Value = myOpt
    
End Sub

'検索結果を表示させる
Private Sub doSearch(ByRef ie As InternetExplorer)
   
    Dim anchor As HTMLAnchorElement

    ie.document.all("button_searchcount").Click
    Do While ie.Busy = True: DoEvents: Loop: Do While ie.document.readyState <> "complete": DoEvents: Loop

    ie.document.all("button_searchResult").Click
    Do While ie.Busy = True: DoEvents: Loop: Do While ie.document.readyState <> "complete": DoEvents: Loop

    For Each anchor In ie.document.getElementsByTagName("A")
        If anchor.className = "detailedLink" Then
            anchor.Click
            Exit For
        End If
    Next
    Do While ie.Busy = True: DoEvents: Loop: Do While ie.document.readyState <> "complete": DoEvents: Loop

    For Each anchor In ie.document.getElementsByTagName("A")
        If anchor.innerText = " 全項目" Then
            anchor.Click
            Exit For
        End If
    Next

End Sub