If you work with a database that you only have access through a web interface, this one is for you. You probably don't have access to any programming languages other than VBA through MS Office, which I 95% guarantee you do have.
Since we will be controlling an external instance of Internet Explorer, you will need to reference Mircosoft Internet Controls for this to work. One could hack this to work with Firefox or Chrome with extensions like Selenium.
Usage
This is meant to be placed in an add-in so we can create an instance from the pseudo-constructors.
Dim navi As Gator
Set navi = Gator.Home("https://www.google.com/", php:=False)
Navigating to a url will raise an error if the browser doesn't navigate to the requested URL. The php:=False option ignores trailing php code added. You can also grab an existing instance of IE using the window title.
Set navi = Gator.FromWindow("Google")
It's nifty if you don't want to re-login to a database or catch a popup window.
There are currently two ways to access HTML elements on the page.
- By id or name
- Using
HtmlFieldsobject
By id is the recommended method if available. You find the id or name of the element and use
With Gator.Home("http://codereview.stackexchange.com/")
.GetElByID("nav-questions").Click
End With
If the element does not have an ID you can specify the tag of the element and any other properties of the sought element
With Gator.Home("http://codereview.stackexchange.com/questions/69009/vba-clickbot-featuring-ajax-waiting-and-element-searching")
.FindEl(HtmlFields.Make("a", innerText:="up vote", _
title:="This question shows research effort; it is useful and clear")).Click
.FindEl(HtmlFields.Make("a", innerText:="add a comment")).Click
.FindEl(HtmlFields.Make("textarea")).value = "WOW! This is super neat!"
.FindEl(HtmlFields.Make("input", value:="Add Comment")).Click
End With
I highly recommend you give that a try
Notice that we aren't required to wait for pages or elements to load. That is the primary purpose of Gator. It will attempt to access the element until it is found or it times out and raises an error. Both methods have an optional timeOut parameter which is default 5 seconds.
Because of the brute force waiting, the code is extremely inefficient. FindEl will perform a linear search on all elements of the given tag name at least 3 times before a successful return. I am looking for ways to reduce that. Still, the inefficiency is negligible in comparison to IE's operations.
Begin Code Dump
HtmlFields
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "HtmlFields"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
' Private Members
' ---------------
''
' Dictionary of `property => result`
Private criteria As Object
Private Sub Class_Initialize()
Set criteria = CreateObject("Scripting.Dictionary")
End Sub
Constructor
I would prefer to allow users to specify the property name of the element searching for instead of restricting them to the one's I have provided. It would be more flexible for the client and less code for me. However, I don't know how I should implement the association between the property and the expected value without inline dictionary definitions which could almost negate this class.
Public Function Make(ByVal tagName As String, _
Optional ByVal className As String = "", _
Optional ByVal value As String = "", _
Optional ByVal innerText As String = "", _
Optional ByVal innerHTML As String = "", _
Optional ByVal typeName As String = "", _
Optional ByVal title As String = "", _
Optional ByVal href As String = "", _
Optional ByVal style As String = "") As HtmlFields
Set Make = New HtmlFields
With Make
If tagName = "" Then
Err.Raise 720, "HtmlFields.Make", "tagName cannot be a null string"
End If
.Add "tagName", UCase(tagName)
.Add "className", className
.Add "value", value
.Add "innerText", innerText
.Add "innerHTML", innerHTML
.Add "type", typeName
.Add "title", title
.Add "href", href
.Add "style", style
End With
End Function
Friend Methods
Soley used for constructor
''
' If value is blank then the option wasn't provided.
Friend Sub Add(ByVal key As String, ByVal value As String)
If value <> "" Then criteria.Add key, value
End Sub
Friend Property Get Count() As Long
Count = criteria.Count
End Property
Public Properties
Public Function GetTags(ByVal htmlDoc As Object) As Object
Set GetTags = htmlDoc.getelementsbytagname(criteria("tagName"))
End Function
Public Function IsMatch(ByVal element As Object) As Boolean
Dim pass As Boolean
Dim field As Variant
For Each field In criteria.Keys
pass = (CallByName(element, field, VbGet) = criteria(field))
If Not pass Then Exit For
Next field
IsMatch = pass
End Function
Gator
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Gator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
' Required .dlls
' `Microsoft Internet Controls`
'
' # Members
' ## Private Members
Private pBrowser As Object
Enum GatorErrors
wrong_location = 360
failed_el_get
End Enum
Public Browser Properties
Public Property Let Visible(ByVal state As Boolean)
pBrowser.Visible = state
End Property
Friend Properties
' For constructors
'
Friend Property Set Browser(ByRef other As InternetExplorer)
Set pBrowser = other
End Property
Friend Property Get Browser() As InternetExplorer
Set Browser = pBrowser
End Property
Constructors
Public Function FromWindow(ByVal title As String) As Gator
WaitFor "PopupExists", title, 30
Dim navi As New Gator
Set navi.Browser = GetWindowFromTitle(title)
Set FromWindow = navi
End Function
Public Function Home(ByVal homeURL As String) As Gator
Dim navi As New Gator
navi.UrlGo homeURL
Set Home = navi
End Function
Navigation
Public Sub UrlGo(ByVal destination As String, Optional php As Boolean = False)
If pBrowser Is Nothing Then Set pBrowser = New InternetExplorer
pBrowser.Visible = True
pBrowser.navigate destination
Wait
Dim location As String
If php Then
location = pBrowser.LocationURL
Else
location = Split(pBrowser.LocationURL, "?")(0)
End If
If location <> destination Then
pBrowser.Visible = True
Err.Raise GatorErrors.wrong_location, "UrlGo", _
"Hey! Listen! Browser didn't navigate to: " & destination
End If
End Sub
Public Routines
Public Sub Quit()
pBrowser.Quit
End Sub
Public Sub Wait()
While pBrowser.readyState <> READYSTATE_COMPLETE Or pBrowser.Busy
DoEvents
Wend
End Sub
Public Sub WaitFor(ByVal existsName As String, ByVal arg0 As Variant, _
ByVal timeOut As Integer)
Dim start As Single
start = timer
Do Until CallByName(Me, existsName, VbMethod, arg0) _
Or start + timeOut < timer
DoEvents
Loop
If Not CallByName(Me, existsName, VbMethod, arg0) Then
pBrowser.Visible = True
Err.Raise GatorErrors.failed_el_get, "WaitFor", _
"Hey!, Listen! " & existsName & " failed to find requested element"
End If
End Sub
Public Accessors
' ### byID
'
' The best way to do it by far. If the website is properly built and every
' element has some kind of ID then this is the way to go.
' You can wait for elements to exist if you know the ID
Public Function GetElByID(ByVal id As String, Optional ByVal timeOut As Long = 5) As Object
WaitFor "IdExists", id, timeOut
Set GetElByID = pBrowser.document.getelementbyID(id)
End Function
Public Function IdExists(ByVal id As String) As Boolean
On Error Resume Next
Dim el As Object
Set el = pBrowser.document.getelementbyID(id)
IdExists = Not (el Is Nothing)
End Function
'
' ### By Filter
'
Public Function FindEl(ByVal fields As HtmlFields, Optional ByVal timeOut As Long = 5) As Object
WaitFor "CanFindElement", fields, timeOut
Set FindEl = FieldSearch(fields)
End Function
Public Function CanFindElement(ByVal fields As HtmlFields) As Boolean
CanFindElement = Not (FieldSearch(fields) Is Nothing)
End Function
### Popup
Public Function PopupExists(ByVal title As String) As Boolean
PopupExists = Not (GetWindowFromTitle(title) Is Nothing)
End Function
Private Accessors
Private Function GetDoc() As Object
Wait
Set GetDoc = pBrowser.document
End Function
Private Function FieldSearch(ByRef fields As HtmlFields) As Object
Dim element As Object
For Each element In fields.GetTags(GetDoc)
If fields.IsMatch(element) Then
Set FieldSearch = element
Exit Function
End If
Next element
End Function
Popup Catching
''
' heavily refactored from StackExchange
' http://stackoverflow.com/questions/14446951/how-to-intercept-and-manipulate-a-internet-explorer-popup-with-vba
' You will need to reference `Microsoft Internet Controls`
Private Function GetWindowFromTitle(ByVal sTitle As String, _
Optional ByVal bCaseSensitive As Boolean = False, _
Optional ByVal bExact As Boolean = False) As SHDocVw.InternetExplorer
Dim objShellWindows As New SHDocVw.ShellWindows
Dim window As SHDocVw.InternetExplorer
For Each window In objShellWindows
If hasWindowTitle(window, sTitle, bCaseSensitive, bExact) Then
Set GetWindowFromTitle = window
Exit Function
End If
Next
Set GetWindowFromTitle = Nothing
End Function
Private Function hasWindowTitle(win As SHDocVw.InternetExplorer, ByVal title As String, _
ByVal bCaseSensitive As Boolean, ByVal bExact As Boolean) As Boolean
On Error GoTo Nope
Dim pass As Boolean
pass = (typeName(win.document) = "HTMLDocument")
If Not pass Then GoTo CleanExit
Dim docTitle As String
docTitle = win.document.title
If Not bCaseSensitive Then
docTitle = LCase(docTitle)
title = LCase(title)
End If
If bExact Then
pass = (docTitle = title)
Else
pass = InStr(1, docTitle, title) <> 0
End If
CleanExit:
hasWindowTitle = pass
Exit Function
Nope:
pass = False
Resume CleanExit
End Function
