Skip to main content
edited tags
Link
RubberDuck
  • 30.9k
  • 6
  • 71
  • 174
added 60 characters in body
Source Link
cheezsteak
  • 2.4k
  • 1
  • 16
  • 33
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
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
        
        If .Count < 2 Then
            Err.Raise 720, "HtmlFields.Make", "At least one optional field must be supplied."
        End If
        
    End With
    
End Function
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
End With
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
        
        If .Count < 2 Then
            Err.Raise 720, "HtmlFields.Make", "At least one optional field must be supplied."
        End If
        
    End With
    
End Function
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
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
Source Link
cheezsteak
  • 2.4k
  • 1
  • 16
  • 33

VBA ClickBot featuring AJAX waiting and Element searching

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.

  1. By id or name
  2. Using HtmlFields object

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
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
        
        If .Count < 2 Then
            Err.Raise 720, "HtmlFields.Make", "At least one optional field must be supplied."
        End If
        
    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