FreeAgent
08-03-2004, 12:14 PM
The purpose of this thread is to educate, so don't be dumb and use this code on any sites other then your own.
Back a few months ago I went through an evil stage in my life, and I made a wicked little prog in vb that sent random private messages to all the forum members. Due to the ever changing vBulletin code it's does not work with some of the newest versions. Here is the source code for all you programmers out there...
Main Form:
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
Module:
' ## 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
I was going to add more features that made it work with all the versions, but I came out of my evil stage before I got to working on the prog anymore.
Back a few months ago I went through an evil stage in my life, and I made a wicked little prog in vb that sent random private messages to all the forum members. Due to the ever changing vBulletin code it's does not work with some of the newest versions. Here is the source code for all you programmers out there...
Main Form:
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
Module:
' ## 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
I was going to add more features that made it work with all the versions, but I came out of my evil stage before I got to working on the prog anymore.