'Required references:
'Microsoft HTML Object Library
'Microsoft Internet Controls
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If
Public Sub IE_Main_Search()
Dim resultsBaseCell As Range
With Range("resultsName").CurrentRegion
Set resultsBaseCell = .Offset(.Rows.Count).Item(1)
End With
IE_POST_Form_Search Range("naam").Value, Range("gemeente").Value, Range("specialisme").Value, resultsBaseCell
End Sub
Private Sub IE_POST_Form_Search(searchName As String, searchPlace As String, searchSpecialisms As String, resultsBaseCell As Range)
Dim IE As InternetExplorer
Dim URL As String
Dim HTMLdoc As HTMLDocument
Dim searchForm As HTMLFormElement
Dim specialismSelect As HTMLSelectElement
Dim results As IHTMLElementCollection
Dim resultDiv As HTMLDivElement
Dim DDelements As IHTMLElementCollection
Dim nextPage As HTMLAnchorElement
Dim specialism As Variant
Dim optionValue As String
Dim formData As String
Dim i As Long, n As Long, page As Long
URL = "https://www.ordomedic.be/nl/zoek-een-arts/"
Set IE = Get_IE_Window2(URL)
If IE Is Nothing Then Set IE = New InternetExplorer
With IE
SetForegroundWindow .hwnd
.navigate URL
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
.Visible = True
Set HTMLdoc = .document
End With
'Get the search form which contains the action URL for sending the form data to
'<form action="https://www.ordomedic.be/nl/zoek-een-arts/" method="post" id="search-register" class="fullpage">
Set searchForm = HTMLdoc.getElementById("search-register")
'Get the Specialism select element. The option value(s) are sent in the form data according to the specified specialism(s)
'<select style="width: 207px; display: none;" multiple="multiple" name="search_specialism[]" id="search_specialism">
' <option value="24" label="Acute geneeskunde">Acute geneeskunde</option>
' <option value="32" label="Algemene geneeskunde">Algemene geneeskunde</option>
' <option value="2" label="Anesthesie-reanimatie">Anesthesie-reanimatie</option>
' <option value="37" label="Arbeidsgeneeskunde">Arbeidsgeneeskunde</option>
' <option value="40" label="Arts" selected="selected">Arts</option>
' <option value="19" label="Cardiologie" selected="selected">Cardiologie</option>
' :
' <option value="11" label="Urologie">Urologie</option>
' <option value="35" label="Verzekeringsgeneeskunde en medische expertise">Verzekeringsgeneeskunde en medische expertise</option>
'</select>
Set specialismSelect = HTMLdoc.getElementById("search_specialism")
'Construct form data string with the following field names (example field values):
'search_name:
'search_place: Dadizele
'search_place_min:
'search_place_max:
'search_specialism[]: 32
'search_specialism[]: 40
formData = URLEncode("search_name") & "=" & URLEncode(searchName) & _
"&" & URLEncode("search_place") & "=" & URLEncode(searchPlace) & _
"&" & URLEncode("search_place_min") & "=" & _
"&" & URLEncode("search_place_max") & "="
'Add specialism option values(s) to form data
For Each specialism In Split(searchSpecialisms, ",")
optionValue = FindSelectOptionValue(specialismSelect, CStr(specialism))
If optionValue <> "" Then
formData = formData & "&" & URLEncode("search_specialism[]") & "=" & URLEncode(optionValue)
End If
Next
'Send form data in IE POST request to perform search and get first page of results
IE_Post_Form_Data IE, searchForm.Action, formData
n = 0
page = 1
Do
'Extract data from this results page
Set results = HTMLdoc.getElementsByClassName("result")
If results.Length > 0 Then
For Each resultDiv In results
'Name and specialism
Set DDelements = resultDiv.Children(0).getElementsByTagName("DD")
For i = 0 To DDelements.Length - 1
resultsBaseCell.Offset(n, i).Value = DDelements(i).innerText
Next
'Address1, Address2, Address3, Address4 and Telephone
Set DDelements = resultDiv.Children(1).getElementsByTagName("DD")
For i = 0 To DDelements.Length - 1
If InStr(DDelements(i).innerText, "Tel.: ") = 1 Then
resultsBaseCell.Offset(n, 6).Value = Mid(DDelements(i).innerText, 7)
Else
resultsBaseCell.Offset(n, i + 2).Value = DDelements(i).innerText
End If
Next
n = n + 1
Next
Else
resultsBaseCell.Offset(n, 0).Value = "No results found"
n = n + 1
End If
'Find link for page number 'page' of results and click it
page = page + 1
Set nextPage = Nothing
i = 0
While i < HTMLdoc.Links.Length And nextPage Is Nothing
If InStr(HTMLdoc.Links(i).href, "&page=" & page) > 0 Then Set nextPage = HTMLdoc.Links(i)
i = i + 1
Wend
If Not nextPage Is Nothing Then
With IE
.navigate nextPage.href
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
End With
End If
'Loop until no more pages or maximum of 200 results has been reached
Loop Until nextPage Is Nothing Or _
InStr(1, HTMLdoc.body.innerText, "Het aantal resultaten dat kan worden bekeken is beperkt tot 200. Gelieve u aan te melden om toegang te krijgen tot de volgende zoekresultaten")
End Sub
Private Sub IE_Post_Form_Data(IE As InternetExplorer, URL As String, formData As String)
'Send URL-encoded form data to the URL using IE
Dim bFormData() As Byte
ReDim bFormData(Len(formData) - 1)
bFormData = StrConv(formData, vbFromUnicode)
With IE
.navigate URL, PostData:=bFormData, Headers:="Content-type: application/x-www-form-urlencoded" & vbCrLf
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Sleep 100: Wend
End With
End Sub
Private Function URLEncode(data As String) As String
'URL-encode of a string data
Dim i As Long, c As Integer
URLEncode = ""
For i = 1 To Len(data)
c = Asc(Mid(data, i, 1))
Select Case c
Case Is = 32: URLEncode = URLEncode & "+"
Case Is < 48: URLEncode = URLEncode & "%" & Hex(c)
Case Else: URLEncode = URLEncode & Mid(data, i, 1)
End Select
Next
End Function
Private Function FindSelectOptionValue(selectElement As HTMLSelectElement, findOptionText As String) As String
'Return the option value for the specified option text
Dim i As Long
FindSelectOptionValue = ""
i = 0
While i < selectElement.Options.Length And FindSelectOptionValue = ""
If selectElement.Item(i).Text = findOptionText Then FindSelectOptionValue = selectElement.Item(i).Value
i = i + 1
Wend
End Function
Private Function Get_IE_Window2(URLorName As String) As InternetExplorer
'Look for an IE browser window or tab already open at the (partial) URL or location name and, if found, return
'that browser as an InternetExplorer object. Otherwise return Nothing
Dim Shell As Object
Dim IE As InternetExplorer
Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
Set Shell = CreateObject("Shell.Application")
i = 0
Set Get_IE_Window2 = Nothing
While i < Shell.Windows.Count And Get_IE_Window2 Is Nothing
Set IE = Shell.Windows.Item(i)
If Not IE Is Nothing Then
If IE.Name = "Internet Explorer" And InStr(IE.LocationURL, "file://") <> 1 Then
If InStr(1, IE.LocationURL, URLorName, vbTextCompare) > 0 Or InStr(1, IE.LocationName, URLorName, vbTextCompare) > 0 Then
Set Get_IE_Window2 = IE
End If
End If
End If
i = i + 1
Wend
End Function
