rcadmodule

rcadble · 02-12-2007, 09:03 PM

I figured since I changed alot, and it's now maybe even worth using, that i'd give it a shot at posting.

RcadMod V3.0 By Rcadble
Required Files:
- comdlg32.ocx (Common Dialog Control) added to project
- Microsoft VBScript Regular Expressions reference added to project
Functions:
- ArrayMatch
- ArrayToList
- CheckArray
- CheckList
- Contains
- DeDupeList
- Extract
- ExtractAll
- ExtractAllB
- FillList
- FillListB
- FindArrayAverage
- FindArrayID
- FindGreatest
- FindGreatestArray
- FindIndex
- FindListAverage
- GetRandomTimer
- InstrCheckArray
- InstrCheckList
- LeftOf
- ListMatch
- ListToArray
- OpenMultiArray
- OpenMultiList
- OpenSingleArray
- OpenSingleList
- PathExists
- Rand
- RemoveItemsWith
- RightOf
- SaveSingleArray
- SaveSingleList
Module Code:

Code:

''RcadModule V_3.0 By rcadble, (rcadble@yahoo.com)
'This module is free to distribute as long as credit is given to me.
'Feedback is appreciated, as well as suggestions.
'Some credit due to http://www.experts-exchange.com/Databases/MS_Access/Q_21078927.html
'Thanks drew010 for help with the regex.
'If you use it, please give me credit somewhere visible to users unless I already granted you permission.
'This module is free to distribute as long as credit is given to rcadble
'If you are encountering errors with the regex functions, hit Project-References and check Microsoft VBScript Regular Expressions 5.5
Public Function PathExists(ByVal strPath As String) As Boolean
    If FileLen(strPath) > 0 Then
        PathExists = True
    Else
        PathExists = False
    End If
End Function
Public Function FillListB(ByVal strString As String, ByVal strLeft As String, ByVal strRight As String, ByVal lstList As ListBox, Optional bolIgnoreCase As Boolean = True, Optional bolClearList As Boolean = True) As Long
    On Error Resume Next
    Dim Regex As RegExp
    Dim objMatch As Match
    Dim colMatches As MatchCollection
    Dim strAdd As String
        If bolClearList = True Then
            lstList.Clear
        End If
        Set Regex = New RegExp
        Regex.Pattern = strLeft & "(.+?)" & strRight
        Regex.IgnoreCase = bolIgnoreCase
        Regex.Global = True
        If Regex.Test(strString) = True Then
            Set colMatches = Regex.Execute(strString)
            If colMatches.Count > 0 Then
                For Each objMatch In colMatches
                    For Each SubMatch In objMatch.SubMatches
                        lstList.AddItem (SubMatch)
                    Next
                Next
            End If
            fillListB = colMatches.Count
            Exit Function
        End If
        FillListB = 0
End Function
Public Function ExtractAllB(ByVal strString As String, ByVal strLeft As String, ByVal strRight As String, ByRef strMatches() As String, Optional bolIgnoreCase As Boolean = True) As Long
    On Error Resume Next
    Dim Regex As RegExp
    Dim objMatch As Match
    Dim colMatches As MatchCollection
    Dim i As Long: i = 0
        Set Regex = New RegExp
        Regex.Pattern = strLeft & "(.+?)" & strRight
        Regex.IgnoreCase = bolIgnoreCase
        Regex.Global = True
        If Regex.Test(strString) = True Then
            Set colMatches = Regex.Execute(strString)
            If colMatches.Count > 0 Then
                ReDim Preserve strMatches(colMatches.Count - 1)
                For Each objMatch In colMatches
                    For Each SubMatch In objMatch.SubMatches
                        strMatches(i) = SubMatch
                        i = i + 1
                    Next
                Next
            End If
            ExtractAllB = colMatches.Count
            Exit Function
        End If
        ExtractAllB = 0
End Function
Public Function DeDupeList(ByVal List As ListBox)
    On Error Resume Next
    Dim lstCollection As New Collection
    Dim i As Long
        For i = 0 To List.ListCount - 1
            lstCollection.Add List.List(i), List.List(i)
        Next
        List.Clear
        For i = 1 To lstCollection.Count
            List.AddItem lstCollection.Item(i)
        Next
End Function
Public Function ArrayMatch(ByRef ArrayOne() As String, ByRef ArrayTwo() As String) As String
    Dim X As Long
    Dim Y As Long
        For X = LBound(ArrayOne) To UBound(ArrayOne)
            For Y = LBound(ArrayTwo) To UBound(ArrayTwo)
                If ArrayOne(X) = ArrayTwo(Y) Then
                    ArrayMatch = ArrayOne(X)
                    Exit Function
                End If
            Next
        Next
End Function
Public Function ListMatch(ByVal ListOne As ListBox, ByVal ListTwo As ListBox) As String
    Dim X As Long
    Dim Y As Long
        For X = 0 To ListOne.ListCount - 1
            For Y = 0 To ListTwo.ListCount - 1
                If ListOne.List(X) = ListTwo.List(Y) Then
                    ListMatch = ListOne.List(X)
                    Exit Function
                End If
            Next
        Next
End Function
Public Function RemoveItemsWith(ByVal List As ListBox, ByVal Search As String)
     Dim strList() As String
     Dim i As Integer
     ReDim strList(List.ListCount - 1) As String
        For i = 0 To List.ListCount - 1
            strList(i) = List.List(i)
        Next
        List.Clear
        For i = LBound(strList) To UBound(strList)
            If InStr(1, strList(i), Search) = 0 Then
                List.AddItem (strList(i))
            End If
        Next
End Function
Public Function ExtractAll(ByVal Source As String, ByVal StartString As String, ByVal EndString As String, ByRef toArray() As String)
    Dim lngStart As Long: lngStart = 1
    Dim strToAdd As String
    Dim lngCount As Long: lngCount = 0
    ReDim toArray(0) As String
        Do
            If InStr(lngStart, Source, StartString) = 0 Then Exit Do
            strToAdd = Extract(Source, StartString, EndString, lngStart)
            lngStart = Val(InStr(lngStart, Source, StartString)) + Len(strToAdd)
            ReDim Preserve toArray(lngCount)
            toArray(lngCount) = strToAdd
            lngCount = lngCount + 1
        Loop
End Function
Public Function ListToArray(ByVal List As ListBox, ByRef toArray() As String) As String()
    Dim i As Long
    ReDim toArray(List.ListCount - 1) As String
        For i = 0 To List.ListCount - 1
            toArray(i) = List.List(i)
        Next
        ListToArray = toArray
End Function
Public Function ArrayToList(ByVal ToList As ListBox, ByRef FromArray() As String, Optional ClearList As Boolean = False)
    If ClearList = True Then
        ToList.Clear
    End If
    For i = LBound(FromArray) To UBound(FromArray)
        ToList.AddItem (FromArray(i))
    Next
End Function
Public Function RightOf(ByVal SearchIn As String, ByVal StartRight As String) As String
    If InStr(1, SearchIn, StartRight) <> 0 Then
        RightOf = Right(SearchIn, Len(SearchIn) - (Val(InStr(1, SearchIn, StartRight)) + Len(StartRight)))
    Else
        RightOf = ""
    End If
End Function
Public Function LeftOf(ByVal SearchIn As String, ByVal StartLeft As String) As String
    If InStr(1, SearchIn, StartLeft) <> 0 Then
        LeftOf = Replace(SearchIn, Right(SearchIn, Len(SearchIn) - Val(InStr(1, SearchIn, StartLeft)) + 1), "")
    Else
        LeftOf = ""
    End If
End Function
Public Function Contains(ByVal SearchIn As String, ByVal SearchFor As String) As Boolean
    If InStr(1, SearchIn, SearchFor) <> 0 Then
        Contains = True
    Else
        Contains = False
    End If
End Function
Public Function SaveSingleArray(ByRef strarray() As String, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|")
    Dim strPath As String: strPath = ""
    Dim i As Long
        On Error GoTo ProcError
        With ctlCommonDialog
            .DefaultExt = "txt"
            .filter = filter
            .FilterIndex = 1
            .ShowSave
            strPath = .FileName
        End With
        If strPath <> "" Then
            Open strPath For Output As #1
                For i = LBound(strarray) To UBound(strarray)
                    Print #1, strarray(i)
                Next
            Close #1
            Exit Function
        End If
ProcError:
        MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        Exit Function
End Function
Public Function SaveSingleList(ByVal List As ListBox, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|")
    Dim strPath As String
    Dim i As Long
        On Error GoTo ProcError
        With ctlCommonDialog
            .DefaultExt = "txt"
            .filter = filter
            .FilterIndex = 1
            .ShowSave
            strPath = .FileName
        End With
        Open strPath For Output As #1
            For i = 0 To List.ListCount - 1
                Print #1, List.List(i)
            Next
        Close #1
        Exit Function
ProcError:
        MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        Exit Function
End Function
Public Function OpenMultiArray(ByRef strarray() As String, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|", Optional ClearList As Boolean = True) As Long
    Dim strFilenames As String
    Dim arrFilenames() As String
    Dim i As Long
    Dim lngCount As Long: lngCount = 0
    Dim strPath As String
        On Error GoTo ProcError
        With ctlCommonDialog
            .filter = filter
            .FilterIndex = 1
            .Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer
            .ShowOpen
            strFilenames = .FileName
        End With
        GoTo procOpen
ProcError:
        If Err.Number = "75" Then
            Exit Function
        Else
            MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        End If
        Exit Function
procOpen:
        arrFilenames = Split(strFilenames, Chr(0))
        If UBound(arrFilenames) > -1 Then
            If UBound(arrFilenames) = 0 Then
                strPath = arrFilenames(0)
                If FileLen(strPath) > 0 Then
                    Open strPath For Input As #1
                        Do Until EOF(1)
                            Input #1, Data
                            ReDim Preserve strarray(lngCount) As String
                            strarray(lngCount) = Data
                            lngCount = lngCount + 1
                            EOF (1)
                        Loop
                    Close #1
                Else
                    OpenMultiArray = 0
                    Exit Function
                End If
            Else
                For i = 1 To UBound(arrFilenames)
                    strPath = arrFilenames(0) & "\" & arrFilenames(i)
                    If FileLen(strPath) > 0 Then
                        Open strPath For Input As #1
                            Do Until EOF(1)
                                Input #1, Data
                                ReDim Preserve strarray(lngCount) As String
                                strarray(lngCount) = Data
                                lngCount = lngCount + 1
                                EOF (1)
                            Loop
                        Close #1
                    Else
                        OpenMultiArray = 0
                        Exit Function
                    End If
                Next
            End If
            OpenMultiArray = UBound(strarray) + 1
        Else
            OpenMultiArray = 0
        End If
End Function
Public Function OpenSingleArray(ByRef strarray() As String, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|") As Long
    Dim strPath As String: strPath = ""
    Dim i As Long: i = 0
        On Error GoTo ProcError
        With ctlCommonDialog
            .filter = filter
            .FilterIndex = 1
            .ShowOpen
            strPath = .FileName
        End With
        GoTo procOpen
ProcError:
        If Err.Number = "75" Then
            Exit Function
        Else
            MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        End If
        Exit Function
procOpen:
        If strPath <> "" Then
            If FileLen(strPath) > 0 Then
                Open strPath For Input As #1
                    Do Until EOF(1)
                        Input #1, Data
                        ReDim Preserve strarray(i) As String
                        strarray(i) = Data
                        i = i + 1
                        EOF (1)
                    Loop
                Close #1
                OpenSingleArray = UBound(strarray) + 1
            Else
                OpenSingleArray = 0
                Exit Function
            End If
        Else
            OpenSingleArray = 0
        End If
End Function
Public Function OpenSingleList(ByVal List As ListBox, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|", Optional ClearList As Boolean = True)
    Dim strPath As String
        On Error GoTo ProcError
        With ctlCommonDialog
            .filter = filter
            .FilterIndex = 1
            .ShowOpen
            strPath = .FileName
        End With
        GoTo procOpen
ProcError:
        If Err.Number = "75" Then
            Exit Function
        Else
            MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        End If
        Exit Function
procOpen:
        If ClearList = True Then
            List.Clear
        End If
        Open strPath For Input As #1
            Do Until EOF(1)
                Input #1, Data
                List.AddItem Data
                EOF (1)
            Loop
        Close #1
        OpenSingleList = List.ListCount
End Function
Public Function OpenMultiList(ByVal List As ListBox, ctlCommonDialog As CommonDialog, Optional filter As String = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|", Optional ClearList As Boolean = True) As Long
    Dim strFilenames As String
    Dim arrFilenames() As String
    Dim i As Long
    Dim strPath As String
        On Error GoTo ProcError
        With ctlCommonDialog
            .filter = filter
            .FilterIndex = 1
            .Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer
            .ShowOpen
            strFilenames = .FileName
        End With
        GoTo procOpen
ProcError:
        If Err.Number = "75" Then
            Exit Function
        Else
            MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error"
        End If
        Exit Function
procOpen:
        If ClearList = True Then
            List.Clear
        End If
        arrFilenames = Split(strFilenames, Chr(0))
        If UBound(arrFilenames) = 0 Then
            strPath = arrFilenames(0)
            Open strPath For Input As #1
                Do Until EOF(1)
                    Input #1, Data
                    List.AddItem Data
                    EOF (1)
                Loop
            Close #1
        Else
            For i = 1 To UBound(arrFilenames)
                strPath = arrFilenames(0) & "\" & arrFilenames(i)
                Open strPath For Input As #1
                    Do Until EOF(1)
                        Input #1, Data
                        List.AddItem Data
                        EOF (1)
                    Loop
                Close #1
            Next
        End If
        OpenMultiList = List.ListCount
End Function
Public Function Rand(ByVal Low As Long, ByVal High As Long) As Long
    Randomize
    Rand = Int(Math.Rnd() * ((High + 1) - Low) + Low)
End Function
Public Function FindArrayAverage(ByRef lngArray() As Long) As Long
    Dim lngTemp As Long
    Dim i As Long
    Dim lngArrCount As Long: lngArrCount = 0
        lngTemp = 0
        For i = LBound(lngArray) To UBound(lngArray)
            lngTemp = lngTemp + lngArray(i)
            lngArrCount = lngArrCount + 1
        Next
        FindArrayAverage = lngTemp / lngArrCount
End Function
Public Function FindListAverage(ByVal List As ListBox) As Long
    Dim lngTemp As Long
    Dim i As Long
        lngTemp = 0
        For i = 0 To List.ListCount - 1
            lngTemp = Val(lngTemp) + Val(List.List(i))
        Next
        FindListAverage = lngTemp / Val(List.ListCount)
End Function
Public Function Extract(ByVal Source As String, ByVal StartString As String, ByVal EndString As String, Optional toStart As Long = 1) As String
    Dim lngBegin As Long
    Dim lngEnd As Long
        lngBegin = Val(InStr(toStart, Source, StartString))
        If Val(lngBegin) = "0" Then
            Extract = ""
            Exit Function
        End If
        lngBegin = Val(lngBegin) + Len(StartString)
        lngEnd = Val(InStr(lngBegin, Source, EndString))
        Extract = Mid$(Source, lngBegin, Val(lngEnd) - Val(lngBegin))
End Function
Public Function FillList(ByVal List As ListBox, ByVal Source As String, ByVal StartString As String, ByVal EndString As String, ByVal ClearList As Boolean)
    Dim lngStart As Long
    Dim strToAdd As String
        lngStart = "1"
        If ClearList = True Then
            List.Clear
        End If
        Do
            If InStr(lngStart, Source, StartString) = 0 Then Exit Do
            strToAdd = Extract(Source, StartString, EndString, lngStart)
            lngStart = Val(InStr(lngStart, Source, StartString)) + Len(strToAdd)
            List.AddItem (strToAdd)
        Loop
End Function
Public Function CheckArray(ByRef strarray() As String, ByVal Search As String) As String
    Dim i As Long
        strItem = ""
        For i = LBound(strarray) To UBound(strarray)
            If strarray(i) = Search Then
                CheckArray = strarray(i)
                Exit Function
            End If
        Next
        CheckArray = "False"
End Function

Public Function CheckList(ByVal List As ListBox, ByVal Search As String) As String
   Dim i As Long
        For i = 0 To List.ListCount - 1
            If List.List(i) = Search Then
                CheckList = List.List(i)
                Exit Function
            End If
        Next
        CheckList = "False"
End Function
Public Function InstrCheckList(ByVal List As ListBox, ByVal Search As String) As String
    Dim strItem As String: strItem = ""
    Dim i As Long
        For i = 0 To List.ListCount - 1
            If InStr(1, List.List(i), Search) <> 0 Then
                InstrCheckList = List.List(i)
                Exit Function
            End If
        Next
        InstrCheckList = "False"
End Function
Public Function InstrCheckArray(ByRef strarray() As String, ByVal Search As String) As String
    Dim strItem As String: strItem = ""
    Dim i As Long
        For i = LBound(strarray) To UBound(strarray)
            If InStr(1, strarray(i), Search) <> 0 Then
                InstrCheckArray = strarray(i)
                Exit Function
            End If
        Next
        InstrCheckArray = "False"
End Function
Public Function FindGreatestArray(ByRef lngArray() As Long) As Long
    Dim lngTemp As Long: lngTemp = 0
    Dim i As Long
        For i = LBound(lngArray) To UBound(lngArray)
            If lngTemp < lngArray(i) Then
                lngTemp = Val(lngArray(i))
            End If
        Next
        FindGreatestArray = lngTemp
End Function
Public Function FindGreatest(ByVal List As ListBox) As Long
    Dim lngTemp As Long: lngTemp = 0
    Dim i As Long
        For i = 0 To List.ListCount - 1
            If lngTemp < Val(List.List(i)) Then
                lngTemp = Val(List.List(i))
            End If
        Next
        FindGreatest = lngTemp
End Function
Public Function GetRandomTimer(ByVal Timer As Timer, ByVal minTime As Long, ByVal maxTime As Long)
    Timer.Interval = Rand(minTime, maxTime)
End Function
Public Function FindIndex(ByVal List As ListBox, ByVal Search As String) As Long
    Dim i As Long
        For i = 0 To List.ListCount - 1
            If List.List(i) = Search Then
                FindIndex = i
                Exit Function
            End If
        Next
End Function
Public Function FindArrayID(ByRef strarray() As String, ByVal Search As String) As Long
    Dim i As Long
        For i = LBound(strarray) To UBound(strarray)
            If strarray(i) = Search Then
                FindArrayID = i
                Exit Function
            End If
        Next
End Function

haven't and wont be active due to fractured thumb, but enjoy

rcadble · 02-12-2007, 09:13 PM

Heres a little source to see some of the functions in use:

Code:

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim strBuyList() As String
Dim strShopStock() As String
Dim strURLs() As String
Dim strPrices() As String
Public Sub Wait(TimeOut As Long)
 Dim TimeNow As Long
 TimeNow = timeGetTime()
 Do
   DoEvents
 Loop While TimeNow + TimeOut > timeGetTime()
End Sub
Public Function StripHeaders(strHTML As String) As String
    Dim strParts() As String
    strParts = Split(strHTML, vbCrLf & vbCrLf, 2)
    StripHeaders = strParts(1)
End Function
Private Sub cmdAdd_Click()
    lstBuy.AddItem InputBox("Please enter the item name here!")
    Call ListToArray(lstBuy, strBuyList)
End Sub
Private Sub cmdLogin_Click()
    Dim strHTML As String
        strHTML = HTTP.GetWrapper("http://neopets.com/")
        lblStatus.Caption = "Logging In Step 1"
        strHTML = HTTP.GetWrapper("http://neopets.com/loginpage.phtml", "http://neopets.com/")
        lblStatus.Caption = "Logging In Step 2"
        strHTML = HTTP.GetWrapper("http://neopets.com/hi.phtml?destination=%2Fpetcentral.phtml&username=" & txtUsername.Text, "http://neopets.com/loginpage.phtml")
        lblStatus.Caption = "Logging In Step 3"
        strHTML = HTTP.GetWrapper("http://neopets.com/login.phtml?username=" & txtUsername.Text & "&password=" & txtPassword.Text & "&destination=%2Fpetcentral.phtml", "http://neopets.com/hi.phtml?destination=%2Fpetcentral.phtml&username=" & txtUsername.Text)
        lblStatus.Caption = "Logging In Step 4"
        If InStr(1, LCase(strHTML), "location: /petcentral.phtml") <> 0 Or InStr(1, LCase(strHTML), "pass_remind") <> 0 Then
            MsgBox "Login Successful!"
            txtUsername.Enabled = False
            txtPassword.Enabled = False
            cmdLogin.Enabled = False
            Call SaveSetting("aber", "main", "user", txtUsername.Text)
            Call SaveSetting("aber", "main", "pass", txtPassword.Text)
            lblStatus.Caption = "Logged in as " & txtUsername.Text
        ElseIf InStr(1, LCase(strHTML), "frozen") <> 0 Then
            MsgBox "This account is frozen!"
            lblStatus.Caption = "Account Frozen!"
        Else
            MsgBox "Invalid user/password combination!"
            lblStatus.Caption = "Invalid user/pass combination!"
        End If

End Sub
Private Sub cmdLogout_Click()
    HTTP.ClearCookies
    txtUsername.Enabled = True
    txtPassword.Enabled = True
    cmdLogin.Enabled = True
    lblStatus.Caption = "Logged out!"
End Sub
Private Sub cmdSave_Click()
    Call RcadModule.SaveSingleList(lstLog, comdlg32)
End Sub

Private Sub cmdStart_Click()
    tmrRefresh.Interval = Rand(txtMin.Text * 1000, txtMax.Text * 1000)
    tmrRefresh.Enabled = True
    lblStatus.Caption = "Beginning to AB soon!"
End Sub

Private Sub cmdStop_Click()
    tmrRefresh.Enabled = False
End Sub

Private Sub Form_Load()
    txtUsername.Text = GetSetting("aber", "main", "user", "(none)")
    txtPassword.Text = GetSetting("aber", "main", "pass", "(none)")
End Sub

Private Sub lstLoad_Click()
    Call RcadModule.OpenMultiList(lstBuy, comdlg32)
    If lstBuy.ListCount > 0 Then
        Call RcadModule.ListToArray(lstBuy, strBuyList)
    End If
End Sub

Private Sub tmrRefresh_Timer()
    Dim strHTML As String
    Dim X As Long, Y As Long
        If lstBuy.ListCount > 0 Then
            lblStatus.Caption = "Grabbing shop stock!"
            strHTML = HTTP.GetWrapper("http://www.neopets.com/objects.phtml?type=shop&obj_type=" & txtShopID.Text, "http://www.neopets.com/objects.phtml?type=shop&obj_type=" & txtShopID.Text)
            If InStr(1, strHTML, "Sorry, we are sold out of everything!") = 0 Then
                lblStatus.Caption = "Extracting data!"
                Call RcadModule.ExtractAllB(strHTML, "Are you sure you wish to purchase ", " at", strShopStock())
                Call RcadModule.ExtractAllB(strHTML, "obj_info_id=", "&g", strURLs())
                Call RcadModule.ExtractAllB(strHTML, "<BR>Cost: ", " NP", strPrices())
                Call RcadModule.ArrayToList(lstShopStock, strShopStock, True)
                For X = LBound(strBuyList) To UBound(strBuyList)
                    For Y = LBound(strShopStock) To UBound(strShopStock)
                        If LCase(strBuyList(X)) = LCase(strShopStock(Y)) Then
                            lblStatus.Caption = "Attempting " & strBuyList(X)
                            Call buyItem(strBuyList(X), "http://www.neopets.com/haggle.phtml?obj_info_id=" & strURLs(Y) & "&brr=1366", Replace(strPrices(Y), ",", ""))
                            Exit Sub
                        End If
                    Next
                Next
            Else
                lblStatus.Caption = "No items in stock!"
            End If
        End If
        Call GetRandomTimer(tmrRefresh, txtMin.Text * 1000, txtMax.Text * 1000)
        lblStatus.Caption = "Waiting " & tmrRefresh.Interval
End Sub
Public Function buyItem(ByVal Name As String, ByVal URL As String, ByVal Price As Long)
    Dim lngHaggle As Long
    Dim strPic As String
    Dim strHTML As String
    Dim strURL As String
    Dim a, b, c As Long
        a = GetTickCount()
        lblStatus.Caption = "Getting haggle page!"
        strHTML = HTTP.GetWrapper(URL, "http://www.neopets.com/objects.phtml?type=shop&obj_type=" & txtShopID.Text)
        b = GetTickCount()
        lngHaggle = (Price * 0.98) - 1
        lblStatus.Caption = "Downloading captcha!"
        strHTML = HTTP.GetWrapper("http://www.neopets.com/captcha_show.phtml", URL)
        strPic = StripHeaders(strHTML)
        Open App.Path & "\captcha.gif" For Output As #1
            Print #1, strPic
        Close #1
        sockOCR.ChangePicture (App.Path & "\captcha.gif")
        lblStatus.Caption = "Posting data!"
        strHTML = HTTP.PostWrapper("http://www.neopets.com/haggle.phtml", "current_offer=" & lngHaggle & sockOCR.OCR, URL)
        c = GetTickCount()
        If InStr(1, LCase(strHTML), "added to your inven") <> 0 Then
            lstLog.AddItem (Time & ": Bought " & Name & " | " & Abs(a - c) & " | " & Abs(b - c))
        Else
            lstLog.AddItem (Time & ": Missed " & Name)
        End If
        lblStatus.Caption = "Waiting 5 seconds!"
        If tmrRefresh.Interval > 5000 Then
            Exit Function
        Else
            Wait (5000 - tmrRefresh.Interval)
        End If
End Function

second2none · 02-13-2007, 07:08 PM

How would I use ExtractAll?
I want it to extract all the URLs to a list box? is that possible

rcadble · 02-14-2007, 08:47 AM

Quote:

Originally Posted by GOD

How would I use ExtractAll?
I want it to extract all the URLs to a list box? is that possible

FillListB or FillList functions were made to almost just that. Just find html you would use to find a getbetween, and then just call the function using all the proper parameters.