Neopets Autopricer

Really old source and also really horrible :P

Option Explicit

'Booleans
Dim bolStop As Boolean
Dim bolPrice As Boolean

'Strings
Dim strHTML As String
Dim strCost As String
Dim strPost As String
Dim strLink As String
Dim stRef As String

'Longs
Dim lngPEnd As Long
Dim lngPStart As Long
Dim lngPrice As Long
Dim lngDone As Long
Dim lngCost As Long
Dim lngNoDec As Long

Private Sub cmdStart_Click()
    'clear the lists
    lstInv.Clear
    lstItems.Clear
    lstObjID.Clear
    lstOldPrice.Clear
    lstNewPrice.Clear
    lstID2.Clear
    lstShopStock.Clear
    lstObjID.Clear
    lstNewID.Clear
    lstOldID.Clear

    'Set status and navigate to the shop
    stsMain.Panels(1).Text = "Status: Getting Shop Information"
    strHTML = HTTPWrapper.GetWrapper("http://www.neopets.com/market.phtml?type=your&view=&obj_name=&lim=30", HTTPWrapper.LastPage)
    
    'Get main shop HTML
    strHTML = Between(strHTML, "or='#dddd77'><b>Description</b><", "</td></tr><tr><td colspan=7 align=center bgcolor='")

    'Get certain information
    Call GrabItems(strHTML, "</b></td><input type='hidden'  name='", "' value=", lstObjID)
    Call GrabItems(strHTML, "' value='", "'><input type='hidden' name=", lstID2)
    Call GrabItems(strHTML, "<td width=60 bgcolor='#ffffcc'><b>", "<", lstShopStock)
    Call GrabItems(strHTML, "'><input type='hidden' name='", "'  value='", lstOldID)
    Call GrabItems(strHTML, "'  value='", "'></td><td align=center bgcolor='#ffffcc'>", lstOldPrice)
    Call GrabItems(strHTML, "</td><td align=center bgcolor='#ffffcc'><input type='text' name='", "' size=6 maxlength=5 value='", lstNewID)
    
    
    'Check for bolstop
    If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub
                    
    'Set the status
    stsMain.Panels(1).Text = "Status: Preparing to Price Items"
    SecondsToWait (1)
    
    bolPrice = True
    
    '' // Price the Items \\ ''
    
    'Set integers back
    lngPStart = 0
    lngPEnd = lstShopStock.ListCount
    lngPrice = 0
    lngDone = 0
    
    Do Until bolPrice = False
        
        'Is the item in the list?
        
        Dim y As Long
        Dim x As Long
        Dim bolSame As Boolean
        Dim intListIndex As Integer
        
        For y = 0 To frmList.lstItemName.ListCount - 1
            If (LCase(frmList.lstItemName.List(y)) = LCase(lstShopStock.List(lngDone))) Then
                bolSame = True
                intListIndex = y
            End If
         Next y
        
        'Check for bolstop
        If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub

        If (bolSame = True) Then
            lstNewPrice.AddItem frmList.lstItemPrice.List(intListIndex)
        Else
        
            Do Until lngPrice = txtStockNumber.Text
                'Check for bolstop
                If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub
                        
                stsMain.Panels(1).Text = "Status: Pricing " & lstShopStock.List(lngDone) & " " & lngPrice + 1 & "/" & txtStockNumber.Text
                'Post the data
                strHTML = HTTPWrapper.PostWrapper("http://www.neopets.com/market.phtml", "type=process_wizard&shopwizard=" & lstShopStock.List(lngDone) & "&table=shop&criteria=exact&min_price=&max_price=", "http://www.neopets.com/market.phtml?type=wizard")
                'Get the price
                strCost = Between(strHTML, "</td><td align=center bgcolor='#ffffcc'><b>", " NP</b></td></tr>")
                strCost = Replace(strCost, ",", "")
                
            lngCost = lngCost + strCost
                lngPrice = lngPrice + 1
            Loop
    
            'Add price to the list
            If optPriceAverage.Value = True Then
                lngCost = lngCost / txtStockNumber.Text
            ElseIf optPricePercentage.Value = True Then
                lngCost = lngCost / txtStockNumber.Text / 100 * txtPricePercent.Text
            End If
            
            If InStr(1, lngCost, ".") Then
                lngNoDec = InStr(1, lngCost)
                lngCost = Left(lngCost, lngNoDec - 1)
            End If
            
            'If is 0
            If lngCost = 0 Then lngCost = 1
            
            lstNewPrice.AddItem lngCost
        End If
        
        lngDone = lngDone + 1
        lngPrice = 0
        lngCost = 0
        
        If lngDone >= lstShopStock.ListCount Then
            bolPrice = False
        End If
                   
    Loop
    
    'Set bolprice back
    bolPrice = True
    
    'Set integers back
    lngPStart = 0
    lngPEnd = lstShopStock.ListCount
    lngPrice = 0
    lngDone = 0
    
    'Check for bolstop
    If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub
    
    'Submit all of the information
    stsMain.Panels(1).Text = "Status: Priced Items."


End Sub

Private Sub cmdStockShop_Click()
    'clear the lists
    lstInv.Clear
    lstItems.Clear
    lstObjID.Clear
    lstOldPrice.Clear
    lstNewPrice.Clear
    lstID2.Clear
    lstShopStock.Clear
    lstObjID.Clear
    lstNewID.Clear
    lstOldID.Clear
    
    'Check for bolstop
    If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub
                    
    'set status
    stsMain.Panels(1).Text = "Status: Preparing to Stock Items"
    SecondsToWait (1)
    
    'Price the items
    strHTML = HTTPWrapper.GetWrapper("http://www.neopets.com/objects.phtml?type=inventory", HTTPWrapper.LastPage)
    Call GrabItems(strHTML, "<a href='javascript:;' onclick='openwin(", "); return false;'>", lstInv)
    Call GrabItems(strHTML, " border=1></a><br>", "<", lstItems)
    
    bolPrice = True
    
    'Make two integers
    lngPEnd = lstInv.ListCount
    lngPStart = "0"
    
    Do Until bolPrice = False
        'Stocking the items
        stsMain.Panels(1).Text = "Status: Stocking " & lstItems.List(lngPStart)
        strHTML = HTTPWrapper.PostWrapper("http://neopets.com/useobject.phtml", "obj_id=" & lstInv.List(lngPStart) & "&obj_weight=1&obj_flags=0&obj_type=Magic+Item&action=stockshop", "http://www.neopets.com/iteminfo.phtml?obj_id=" & lstInv.List(lngPStart))
        'if you dont have a shop
        If InStr(1, strHTML, "You are trying to move items into a shop, but we are not finding a shop owned by you!") Then
            stsMain.Panels(1).Text = "Status: You do not have a shop."
            SecondsToWait (1)
            Exit Sub
        End If
        lngPStart = lngPStart + 1
        If lngPStart >= lngPEnd Then
            stsMain.Panels(1).Text = "Status: Added all items to your shop."
            SecondsToWait (1)
            Exit Do
        End If
    Loop
    
          
End Sub

Private Sub cmdStop_Click()
    bolStop = True
End Sub

Private Sub cmdUpdate_Click()
    
    strPost = "type=update_prices&order_by=&view=&"
            
    'combine the post data
    Do Until bolPrice = False
        If lstOldID.List(lngPStart) = "" Then
            bolStop = False
        End If
        strPost = strPost & lstObjID.List(lngPStart) & "=" & lstID2.List(lngPStart) & "&" & lstOldID.List(lngPStart) & "=" & lstOldPrice.List(lngPStart) & "&" & lstNewID.List(lngPStart) & "=" & lstNewPrice.List(lngPStart) & "&back_to_inv%5B" & lstID2.List(lngPStart) & "%5D=0&"
        If lngPStart >= lstShopStock.ListCount Then
            bolPrice = False
        Else
            lngPStart = lngPStart + 1
        End If
    Loop
    
    'strPost = strPost & "obj_name="
    strPost = Replace(strPost, "&=&=&=&back_to_inv%5B%5D=0&", "")
    strPost = strPost & "&lim=30&obj_name="
    
    strLink = "http://www.neopets.com/process_market.phtml"
    stRef = "http://www.neopets.com/market.phtml?type=your"
                    
    'Post the info
    strHTML = HTTPWrapper.PostWrapper(strLink, strPost, stRef)
                    
    'Check for bolstop
    If bolStop = True Then: stsMain.Panels(1).Text = "Status: Program Stopped": bolStop = False: Exit Sub
                    
    If InStr(1, strHTML, "Location: market.phtml?type=your&view=&obj_name=&lim=") Then
        stsMain.Panels(1).Text = "Status: Submitted New Prices."
    Else
        stsMain.Panels(1).Text = "Status: Unable to update shop."
    End If
    
    'Wait second and return to autobuyer
    SecondsToWait (1)


End Sub

Private Sub Form_UnLoad(Cancel As Integer)
    End
End Sub

Private Sub lstNewPrice_dblClick()
Dim lngNumber As Long

On Error GoTo Error

    lngNumber = InputBox("Please enter your new price", "New Price", lstNewPrice.List(lstNewPrice.ListIndex))
    lstNewPrice.List(lstNewPrice.ListIndex) = lngNumber
    
    Exit Sub
    
Error:
    Exit Sub
End Sub

Private Sub mnuSaveable_Click()
    frmList.Show
End Sub