Dim arrSites() As String

Private Sub cmdGo_Click()
    ' Go
    Dim A As Integer
    Dim b As Integer
    Dim page As Integer
    Dim otr As IHTMLElementCollection
    Dim otd As IHTMLElementCollection
    Dim doc As HTMLDocument
    Dim docMsg As HTMLDocument
    Dim tmpDate As Date
    Dim oForm As HTMLFormElement
    Dim arrMsg() As String
    Dim intMaxPage As Integer
    Dim tmpStr As String
    Dim intDJidx As Integer
    Dim intRowStart As Integer
    Dim I As Variant
    Dim C As Integer
    Dim tmpStr2 As String
    Dim tmpObj As Object
    Dim strUIDTag As String
    
    For A = 0 To UBound(arrSites)
        
        page = 0
        Do
            page = page + 1
            Set doc = getDoc("http://" & arrSites(A) & "/memberlist.php?&order=desc&what=datejoined&sort=joindate&pp=30&page=" & page & "", web)
            DoEvents
            Set otr = doc.getElementsByTagName("TR")
            
            ' Find teh starting row
            Set otd = doc.getElementsByTagName("TD")
            For b = 0 To otd.length - 1
                If Trim(LCase(otd(b).innerText)) = "user name" Then
                    DoEvents
                    ' Now find the matching index by comparing the SourceIndex properties
                    ' of each row.
                    For C = 0 To otr.length
                        If otr(C).sourceIndex = otd(b).parentElement.sourceIndex Then
                            intRowStart = C + 1
                            Exit For
                        End If
                    Next C
                    Exit For
                End If
            Next b
            
            ' Find date joined index
            For b = 0 To otr(intRowStart - 1).children.length - 1
                If InStr(1, LCase(otr(intRowStart - 1).children(b).innerText), "join") > 0 Then intDJidx = b
            Next b
            
            For b = intRowStart To otr.length - 5
                ' rip data
                DoEvents
                If otr(b).children(intDJidx).innerText = "Today" Then
                    tmpDate = Date
                ElseIf otr(b).children(intDJidx).innerText = "Yesterday" Then
                    tmpDate = Date - 1
                ElseIf IsDate(otr(b).children(intDJidx).innerText) Then
                    tmpDate = CDate(otr(b).children(intDJidx).innerText)
                End If
                ' date comparison
                If DateDiff("d", Me.txtJoinDate.Text, tmpDate) >= 0 Then
                    ' send msg
                    Set tmpObj = otr(b)
                    On Error Resume Next
                    Do
                        ' Loop and find A
                        Err.Clear
                        Set tmpObj = tmpObj.children(0)
                    Loop Until (UCase(tmpObj.nodeName) = "A") Or (Err.Number <> 0)
                    tmpStr2 = tmpObj.href
                    On Error GoTo 0
                    
                    ' Get the UID tag
                    strUIDTag = modGlobal.GetQuerystringValue(CStr(tmpStr2), "u")
                    If strUIDTag = "" Then strUIDTag = modGlobal.GetQuerystringValue(CStr(tmpStr2), "userid")
                    
                    Set docMsg = getDoc("http://" & arrSites(A) & "/private.php?do=newpm&u=" & strUIDTag, webMsg)
                    DoEvents
                    Set oForm = docMsg.Forms(1)
                    ' docMsg.getElementsByName("ICONID").Item(CInt(Rnd * (docMsg.getElementsByName("ICONID").length - 1))).Checked = True
                    arrMsg = Split(RandLineFromFile("messages.txt"), "|")
                    oForm("title").Value = arrMsg(0)
                    oForm("message").Value = Replace(arrMsg(1), "~", vbCrLf)
                    oForm.onsubmit = ""
                    oForm("sbutton").Click
                    WaitUntilDone webMsg, 60
                Else
                    ' Exit the DO loop
                    Exit Do
                End If
            Next b
            ' Next page
            
            DoEvents
            tmpStr = otr(otr.length - 4).children(0).children(0).children(0).children(0)  .children(0).children(0).innerText
            tmpStr = Replace(tmpStr, "Page " & CStr(page) & " of ", "")
            If IsNumeric(tmpStr) Then
                intMaxPage = CInt(tmpStr)
            Else
                intMaxPage = page
            End If
        Loop Until page = intMaxPage
        
    Next A
    MsgBox "Done."
End Sub

Private Sub Form_Load()
    arrSites = Split(ReadFile(App.Path & "\sites.txt"), vbCrLf)
    If UBound(arrSites) = -1 Then
        MsgBox "Need sites.txt to be populated with vBulletin sites."
        End
    Else
        web.navigate arrSites(0)
    End If
    txtJoinDate = CStr(Date - 7)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

' ## standard functions

' as name implies
Function RandLineFromArray(arr)
    RandLineFromArray = Trim(arr(CInt(Rnd * UBound(arr))))
End Function

' Remove #s from a string
Function RemoveNums(bstr As String)
    RemoveNums = bstr
    For A = Asc("0") To Asc("9")
        RemoveNums = Replace(RemoveNums, Chr(A), "")
    Next A
End Function

Function GetQuerystringValue(URL As String, Name As String, Optional DelimChar As String = "?", Optional SepChar As String = "&") As String
'On Error Resume Next
    ' Gets querystring value from URL
    Dim temp, t1, t2
    temp = Mid(URL, InStr(1, URL, DelimChar) + 1, Len(URL))
    t1 = Split(temp, SepChar)
    For A = 0 To UBound(t1)
        t2 = Split(t1(A), "=")
        If UCase(t2(0)) = UCase(Name) Then GetQuerystringValue = t2(1)
    Next
End Function

Function getDoc(URL As String, webcontrol) As HTMLDocument
'On Error Resume Next
    CommandDone = False
    webcontrol.navigate URL
    WaitUntilDone webcontrol
    Set getDoc = webcontrol.document
End Function

Function Pause(secs As Integer)
'On Error Resume Next
    ' Pauses for X amount of seconds
    Dim tnow As Date
    tnow = Now()
    Do
        DoEvents
    Loop Until DateDiff("s", tnow, Now()) >= secs
End Function

Function WaitUntilDone(webcontrol, Optional Seconds As Integer = 10)
On Error Resume Next
    Dim dtmStartTime
    'wait for the browser to start loading
    dtmStartTime = Now()
    Do Until webcontrol.readyState <> READYSTATE_COMPLETE Or DateDiff("s", dtmStartTime, Now()) > Seconds
        DoEvents
    Loop
    
    'Wait for the browser to stop loading
    If Seconds > 0 Then
        dtmStartTime = Now()
        Do Until (webcontrol.readyState = READYSTATE_COMPLETE And DateDiff("s", dtmStartTime, Now()) > Seconds) Or DateDiff("s", dtmStartTime, Now()) > Seconds
            DoEvents
        Loop
    Else
        dtmStartTime = Now()
        Do Until webcontrol.readyState = READYSTATE_COMPLETE Or DateDiff("s", dtmStartTime, Now()) > Seconds
            DoEvents
        Loop
    End If
End Function

Function ClickLink(doc As HTMLDocument, linkHTML As String) As String
'On Error Resume Next
    ' Gets the URL for a link (the first that matches)
    Dim A As Integer, hrefs As IHTMLElementCollection
    Set hrefs = doc.getElementsByTagName("A")
    For A = 0 To hrefs.length - 1
        If UCase(hrefs(A).innerHTML) = UCase(linkHTML) Then
            hrefs(A).Click
            Exit Function
        End If
    Next A
End Function

Function GetHREF(doc As HTMLDocument, linkHTML As String) As String
'On Error Resume Next
    ' Gets the URL for a link (the first that matches)
    Dim A As Integer, hrefs As IHTMLElementCollection
    Set hrefs = doc.getElementsByTagName("A")
    For A = 0 To hrefs.length - 1
        If UCase(hrefs(A).innerHTML) = UCase(linkHTML) Then
            GetHREF = hrefs(A).href
            Exit Function
        End If
    Next A
End Function

' ## Other

Function RandLineFromFile(fname As String)
    Dim temp As String, t As String, arrt() As String, rn As Integer
    Open App.Path & "\" & fname For Input As #1
    Do While Not EOF(1)
        Line Input #1, t
        temp = temp & t & vbCrLf
    Loop
    ' split
    arrt = Split(temp, vbCrLf)
    Do
        rn = CInt(Rnd * UBound(arrt))
    Loop Until arrt(rn) <> ""
    RandLineFromFile = arrt(rn)
    Close #1
End Function

Function AppendToFile(filename, what)
    Open App.Path & "\" & filename For Append As #2
    Print #2, what
    Close #2
End Function

'' ## REQUIRES REGEXP DLL TO BE ASSOCIATED IN REFERENCES
'Function FindEmails(InputStr) As String
'    Dim temp As String
'    Dim rx As RegExp, MatchCol As MatchCollection
'    Set rx = New RegExp
'    With rx
'        .Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9._%-]+\.[A-Z0-9._%-]{2,4}\b"
'        .IgnoreCase = True
'        .MultiLine = True
'        .Global = True
'        Set MatchCol = .Execute(InputStr)
'    End With
'    For A = 0 To MatchCol.Count - 1
'        temp = temp & MatchCol.Item(A).Value & vbCrLf
'    Next A
'    If temp <> "" Then FindEmails = Left(temp, Len(temp) - 2)
'End Function

Function ReadFile(filename As String)
    Dim k As Integer, s As String
    k = FreeFile()
    Open filename For Input As #k
    Do While Not EOF(k)
        Line Input #k, s
        ReadFile = ReadFile & s & vbCrLf
    Loop
    Close #k
End Function