Option Explicit
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
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
Set searchForm = HTMLdoc.getElementById("search-register")
Set specialismSelect = HTMLdoc.getElementById("search_specialism")
formData = URLEncode("search_name") & "=" & URLEncode(searchName) & _
"&" & URLEncode("search_place") & "=" & URLEncode(searchPlace) & _
"&" & URLEncode("search_place_min") & "=" & _
"&" & URLEncode("search_place_max") & "="
For Each specialism In Split(searchSpecialisms, ",")
optionValue = FindSelectOptionValue(specialismSelect, CStr(specialism))
If optionValue <> "" Then
formData = formData & "&" & URLEncode("search_specialism[]") & "=" & URLEncode(optionValue)
End If
Next
IE_Post_Form_Data IE, searchForm.Action, formData
n = 0
page = 1
Do
Set results = HTMLdoc.getElementsByClassName("result")
If results.Length > 0 Then
For Each resultDiv In results
Set DDelements = resultDiv.Children(0).getElementsByTagName("DD")
For i = 0 To DDelements.Length - 1
resultsBaseCell.Offset(n, i).Value = DDelements(i).innerText
Next
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
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 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)
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
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
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
Dim Shell As Object
Dim IE As InternetExplorer
Dim i As Variant
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
