Skip to content

Commit b0d264a

Browse files
timhalltimhall
committed
Add OPS Example
1 parent fffcbcc commit b0d264a

File tree

4 files changed

+239
-1
lines changed

4 files changed

+239
-1
lines changed

‎credentials - example.txt

+6-1
Original file line numberDiff line numberDiff line change
@@ -38,4 +38,9 @@ Todoist
3838
# Url: https://todoist.com/app_console/
3939
- id: Your Client Id
4040
- secret: Your Client Secret
41-
- redirect_url: Your Redirect Url
41+
- redirect_url: Your Redirect Url
42+
43+
OPS
44+
# Url: http://www.epo.org/searching-for-patents/technical/espacenet/ops.html
45+
- consumer_key: Your consumer key
46+
- consumer_secret: Your consumer secret

‎examples/VBA-Web - Example.xlsm

74.5 KB
Binary file not shown.

‎examples/ops/OPS.bas

+177
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,177 @@
1+
Attribute VB_Name = "OPS"
2+
Private pOPSConsumerKey As String
3+
Private pOPSConsumerSecret As String
4+
Private pClient As WebClient
5+
6+
Private Property Get OPSConsumerKey() As String
7+
If pOPSConsumerKey = "" Then
8+
If Credentials.Loaded Then
9+
pOPSConsumerKey = Credentials.Values("OPS")("consumer_key")
10+
Else
11+
pOPSConsumerKey = InputBox("Please Enter OPS Consumer Key")
12+
End If
13+
End If
14+
15+
OPSConsumerKey = pOPSConsumerKey
16+
End Property
17+
Private Property Get OPSConsumerSecret() As String
18+
If pOPSConsumerSecret = "" Then
19+
If Credentials.Loaded Then
20+
pOPSConsumerSecret = Credentials.Values("OPS")("consumer_secret")
21+
Else
22+
pOPSConsumerSecret = InputBox("Please Enter OPS Consumer Secret")
23+
End If
24+
End If
25+
26+
OPSConsumerSecret = pOPSConsumerSecret
27+
End Property
28+
29+
Public Property Get Client() As WebClient
30+
If pClient Is Nothing Then
31+
Set pClient = New WebClient
32+
pClient.BaseUrl = "https://ops.epo.org/3.1/"
33+
34+
' Setup authenticator (note: provide consumer key and secret here
35+
Dim Auth As New OPSAuthenticator
36+
Auth.Setup OPSConsumerKey, OPSConsumerSecret
37+
38+
' If there are issues automatically getting the token with consumer key / secret
39+
' the token can be found in the developer console and manually entered here
40+
' Auth.Token = "AUTH_TOKEN"
41+
42+
Set pClient.Authenticator = Auth
43+
44+
' Add XML converter
45+
WebHelpers.RegisterConverter "xml", "application/xml", "OPS.ConvertToXml", "OPS.ParseXml"
46+
End If
47+
48+
Set Client = pClient
49+
End Property
50+
51+
Public Function Search(Query As String) As Collection
52+
#If Mac Then
53+
Err.Raise 11099, Description:="XML services (such as the OPS example) are not currently supported on the Mac (Note: OPS supports JSON, but XML is used for this example)"
54+
#Else
55+
Dim Request As New WebRequest
56+
Request.Resource = "rest-services/published-data/search"
57+
Request.CustomResponseFormat = "xml"
58+
Request.AddQuerystringParam "q", Query
59+
60+
Dim Response As WebResponse
61+
Set Response = Client.Execute(Request)
62+
63+
If Response.StatusCode = WebStatusCode.Ok Then
64+
Set Search = GetBiblioData(GetDocNumbers(Response.Data))
65+
End If
66+
#End If
67+
End Function
68+
69+
Public Function GetBiblioData(DocNumbers As Variant) As Collection
70+
Dim Request As New WebRequest
71+
Request.Resource = "rest-services/published-data/publication/epodoc/{number}/biblio"
72+
Request.AddUrlSegment "number", VBA.Join(DocNumbers, ",")
73+
Request.CustomResponseFormat = "xml"
74+
75+
Dim Response As WebResponse
76+
Set Response = Client.Execute(Request)
77+
78+
If Response.StatusCode = WebStatusCode.Ok Then
79+
Dim Documents As Object
80+
Dim Doc As Object
81+
Dim Results As New Collection
82+
Dim Result As Dictionary
83+
Dim Child As Object
84+
Dim Title As String
85+
Dim Index As Long
86+
87+
Set Documents = GetChild(GetChild(Response.Data, "ops:world-patent-data"), "exchange-documents")
88+
Index = 0
89+
For Each Doc In Documents.ChildNodes
90+
' Get English title
91+
For Each Child In GetChildren(GetChild(Doc, "bibliographic-data"), "invention-title")
92+
If GetAttribute(Child, "lang") = "en" Then
93+
Title = Child.Text
94+
Exit For
95+
End If
96+
Next Child
97+
98+
Set Result = New Dictionary
99+
Result.Add "title", Title
100+
Result.Add "number", DocNumbers(Index)
101+
102+
Results.Add Result
103+
104+
Index = Index + 1
105+
Next Doc
106+
107+
Set GetBiblioData = Results
108+
End If
109+
End Function
110+
111+
Private Function GetDocNumbers(SearchData As Object) As Variant
112+
Dim Results As Object
113+
Dim DocNumbers() As String
114+
Dim Child As Object
115+
Dim Index As Long
116+
Dim Country As String
117+
Dim Num As String
118+
Dim Kind As String
119+
120+
Set Results = GetChild(GetChild(GetChild(SearchData, "ops:world-patent-data"), "ops:biblio-search"), "ops:search-result").ChildNodes
121+
ReDim DocNumbers(Results.Length - 1)
122+
Index = 0
123+
For Each Child In Results
124+
Country = GetChild(GetChild(Child, "document-id"), "country").Text
125+
Num = GetChild(GetChild(Child, "document-id"), "doc-number").Text
126+
Kind = GetChild(GetChild(Child, "document-id"), "kind").Text
127+
128+
DocNumbers(Index) = Country & Num & "." & Kind
129+
Index = Index + 1
130+
Next Child
131+
132+
GetDocNumbers = DocNumbers
133+
End Function
134+
135+
' Enable XML parsing/converting
136+
' https://github.com/VBA-tools/VBA-Web/wiki/XML-Support-in-4.0
137+
Public Function ParseXml(Value As String) As Object
138+
Set ParseXml = CreateObject("MSXML2.DOMDocument")
139+
ParseXml.Async = False
140+
ParseXml.LoadXML Value
141+
End Function
142+
143+
Public Function ConvertToXml(Value As Variant) As String
144+
ConvertToXml = VBA.Trim$(VBA.Replace(Value.Xml, vbCrLf, ""))
145+
End Function
146+
147+
Private Function GetChildren(Node As Object, Name As String) As Collection
148+
Dim Child As Object
149+
Dim Children As New Collection
150+
For Each Child In Node.ChildNodes
151+
If Child.nodeName = Name Then
152+
Children.Add Child
153+
End If
154+
Next Child
155+
156+
Set GetChildren = Children
157+
End Function
158+
159+
Private Function GetChild(Node As Object, Name As String) As Object
160+
Dim Child As Object
161+
For Each Child In Node.ChildNodes
162+
If Child.nodeName = Name Then
163+
Set GetChild = Child
164+
Exit Function
165+
End If
166+
Next Child
167+
End Function
168+
169+
Private Function GetAttribute(Node As Object, Name As String) As String
170+
Dim Attr As Object
171+
For Each Attr In Node.Attributes
172+
If Attr.Name = Name Then
173+
GetAttribute = Attr.Text
174+
Exit Function
175+
End If
176+
Next Attr
177+
End Function

‎examples/ops/OPSSheet.cls

+56
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "OPSSheet"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = True
9+
Attribute VB_Exposed = True
10+
Private Const OPSResultsFirstRow As Integer = 5
11+
Private Const OPSResultsCount As Integer = 25
12+
Private Const OPSResultsCol As Integer = 2
13+
14+
Public Sub SearchOPS()
15+
ClearResults
16+
17+
Dim Results As Collection
18+
Dim Query As String
19+
20+
Query = Me.[OPSQuery]
21+
If Query <> "" Then
22+
Set Results = OPS.Search(Query)
23+
OutputResults Results
24+
End If
25+
End Sub
26+
27+
Private Sub ClearResults()
28+
Dim PrevUpdating As Boolean
29+
PrevUpdating = Application.ScreenUpdating
30+
Application.ScreenUpdating = False
31+
32+
Dim LastRow As Integer
33+
LastRow = OPSResultsFirstRow + OPSResultsCount - 1
34+
Me.Rows(OPSResultsFirstRow & ":" & LastRow).ClearContents
35+
36+
Application.ScreenUpdating = PrevUpdating
37+
End Sub
38+
39+
Private Sub OutputResults(Results As Collection)
40+
Dim PrevUpdating As Boolean
41+
PrevUpdating = Application.ScreenUpdating
42+
Application.ScreenUpdating = False
43+
44+
Dim Result As Dictionary
45+
Dim Row As Integer
46+
47+
Row = OPSResultsFirstRow
48+
For Each Result In Results
49+
Me.Cells(Row, OPSResultsCol).Value = Result("title")
50+
51+
Row = Row + 1
52+
Next Result
53+
54+
Application.ScreenUpdating = PrevUpdating
55+
End Sub
56+

0 commit comments

Comments
 (0)