Results 1 to 1 of 1

Thread: [VB6] Account Checker

  1. #1
    Reemer's Avatar
    Joined
    Dec 2011
    Posts
    639
    Userbars
    8
    Thanks
    364
    Thanked
    446/256
    DL/UL
    39/0
    Mentioned
    203 times
    Time Online
    4d 13h 47m
    Avg. Time Online
    1m

    [VB6] Account Checker

    This is like 7 years old, before I even started (and finished) my computer engineering degree. Don't judge for how bad it is.
    It was copied from my SDB checker, hence the name. I don't think this was the version that was released. I can't find that source.
    Code:
    VERSION 5.00
    Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "ComDlg32.OCX"
    Begin VB.Form frmchecker 
       Caption         =   "Reemer's SDB Checker"
       ClientHeight    =   6675
       ClientLeft      =   2685
       ClientTop       =   2085
       ClientWidth     =   7815
       Icon            =   "checker.frx":0000
       LinkTopic       =   "Form1"
       ScaleHeight     =   6675
       ScaleWidth      =   7815
       Begin VB.ListBox lstmove 
          Height          =   645
          Left            =   4920
          TabIndex        =   29
          Top             =   5760
          Width           =   615
       End
       Begin VB.ListBox lstdefence 
          Height          =   645
          Left            =   4200
          TabIndex        =   28
          Top             =   5760
          Width           =   615
       End
       Begin VB.ListBox lststrength 
          Height          =   645
          Left            =   3480
          TabIndex        =   27
          Top             =   5760
          Width           =   615
       End
       Begin VB.ListBox lsthealth 
          Height          =   645
          Left            =   2640
          TabIndex        =   26
          Top             =   5760
          Width           =   735
       End
       Begin VB.ListBox lstlvl 
          Height          =   645
          Left            =   1800
          TabIndex        =   25
          Top             =   5760
          Width           =   735
       End
       Begin VB.ListBox lstcolour 
          Height          =   645
          Left            =   960
          TabIndex        =   24
          Top             =   5760
          Width           =   735
       End
       Begin VB.ListBox lstspecies 
          Height          =   645
          Left            =   120
          TabIndex        =   23
          Top             =   5760
          Width           =   735
       End
       Begin VB.ListBox lstGBA 
          Height          =   840
          Left            =   120
          TabIndex        =   22
          Top             =   2280
          Width           =   1215
       End
       Begin VB.TextBox txtproxy 
          Height          =   285
          Left            =   1200
          TabIndex        =   21
          Text            =   "host:port"
          Top             =   5040
          Width           =   1215
       End
       Begin VB.CheckBox chkProxy 
          Caption         =   "Use Proxy"
          Height          =   255
          Left            =   0
          TabIndex        =   20
          Top             =   5040
          Width           =   1095
       End
       Begin VB.CommandButton Command1 
          Caption         =   "Test Proxy"
          Height          =   255
          Left            =   2640
          TabIndex        =   19
          Top             =   5040
          Width           =   1095
       End
       Begin VB.CheckBox chkproglog 
          Caption         =   "Save as ProgLog.txt upon closure"
          Height          =   255
          Left            =   5040
          TabIndex        =   18
          Top             =   5400
          Value           =   1  'Checked
          Width           =   2775
       End
       Begin VB.TextBox txtsave 
          Height          =   285
          Left            =   6840
          TabIndex        =   16
          Text            =   "ProgLog"
          Top             =   4920
          Width           =   855
       End
       Begin VB.CommandButton cmdclearitems 
          Caption         =   "Clear"
          Height          =   255
          Left            =   2040
          TabIndex        =   13
          Top             =   4200
          Width           =   735
       End
       Begin VB.CommandButton cmdloaditems 
          Caption         =   "Load"
          Height          =   255
          Left            =   1080
          TabIndex        =   12
          Top             =   4200
          Width           =   855
       End
       Begin VB.CommandButton cmdSave 
          Caption         =   "Save log"
          Height          =   315
          Left            =   6600
          TabIndex        =   11
          Top             =   4560
          Width           =   1095
       End
       Begin MSComDlg.CommonDialog CD 
          Left            =   4200
          Top             =   5040
          _ExtentX        =   847
          _ExtentY        =   847
          _Version        =   393216
       End
       Begin VB.CommandButton cmdclear 
          Caption         =   "Clear"
          Height          =   255
          Left            =   1920
          TabIndex        =   10
          Top             =   1920
          Width           =   735
       End
       Begin VB.CommandButton cmdload 
          Caption         =   "Load"
          Height          =   255
          Left            =   1080
          TabIndex        =   9
          Top             =   1920
          Width           =   735
       End
       Begin VB.ListBox lstaccounts 
          Height          =   1425
          ItemData        =   "checker.frx":FE51
          Left            =   240
          List            =   "checker.frx":FE53
          TabIndex        =   8
          Top             =   360
          Width           =   2415
       End
       Begin Project1.ctlRipperWrapper RipperWrapper 
          Left            =   4320
          Top             =   4800
          _ExtentX        =   847
          _ExtentY        =   847
          GZip            =   0   'False
          Timeout         =   8000
       End
       Begin VB.ListBox lststatus 
          Height          =   3960
          Left            =   3000
          TabIndex        =   7
          Top             =   360
          Width           =   4575
       End
       Begin VB.TextBox txtwait2 
          Height          =   285
          Left            =   2040
          TabIndex        =   5
          Text            =   "1000"
          Top             =   5400
          Width           =   495
       End
       Begin VB.TextBox txtwait1 
          Height          =   285
          Left            =   1080
          TabIndex        =   4
          Text            =   "500"
          Top             =   5400
          Width           =   495
       End
       Begin VB.CommandButton cmdstop 
          Caption         =   "Stop"
          Height          =   375
          Left            =   1080
          TabIndex        =   1
          Top             =   4560
          Width           =   975
       End
       Begin VB.CommandButton cmdStart 
          Caption         =   "Start"
          Height          =   375
          Left            =   0
          TabIndex        =   0
          Top             =   4560
          Width           =   975
       End
       Begin VB.Frame Frame2 
          Caption         =   "Log"
          Height          =   4335
          Left            =   2880
          TabIndex        =   14
          Top             =   120
          Width           =   4815
       End
       Begin VB.Frame Frame3 
          Caption         =   "Accounts"
          Height          =   1815
          Left            =   120
          TabIndex        =   15
          Top             =   120
          Width           =   2655
       End
       Begin VB.Label Label1 
          Caption         =   "Save log as"
          Height          =   255
          Left            =   5880
          TabIndex        =   17
          Top             =   4920
          Width           =   855
       End
       Begin VB.Label Label3 
          Caption         =   "ms between refreshes"
          Height          =   255
          Left            =   2640
          TabIndex        =   6
          Top             =   5400
          Width           =   1575
       End
       Begin VB.Label Label2 
          Caption         =   "Wait between              and"
          Height          =   255
          Left            =   0
          TabIndex        =   3
          Top             =   5400
          Width           =   1935
       End
       Begin VB.Label lblstatus 
          Caption         =   "Status"
          Height          =   255
          Left            =   2280
          TabIndex        =   2
          Top             =   4680
          Width           =   3495
       End
    End
    Attribute VB_Name = "frmchecker"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Dim strHTML As String
    Dim strprocess As String
    Dim StopProgram As Boolean
    Dim strMyNeopoints As String
    Dim strlocation As String
    Dim host As String
    Dim port As String
    Dim Retry As Boolean
    Public Function GBA(ByVal Str As String, start As String, Finish As String, lstAdd As ListBox, Optional Clear As Boolean = True, Optional lgB As Long = 1) As String
               On Error Resume Next
               If Clear = True Then lstAdd.Clear
               Do Until lgB <= lngStop
                          lgB = InStr(lgB, Str, start)
                          If lgB + Len(start) >= Len(Str) Or lgB = 0 Then Exit Function
                          If lgB <> 0 Then lgB = lgB + Len(start): GBA = Mid$(Str, lgB, InStr(lgB, Str, Finish) - lgB): lgB = lgB + 1
                          lstAdd.AddItem GBA
               Loop
    End Function
    Public Function GetStringBetween(ByVal InputText As String, _
          ByVal StartText As String, _
          ByVal EndText As String, _
          Optional ByVal StartPosition = 1) As String
           Dim lnTextStart As Long
          Dim lnTextEnd As Long
    
           lnTextStart = InStr(StartPosition, InputText, StartText, vbTextCompare) + Len(StartText)
          lnTextEnd = InStr(lnTextStart, InputText, EndText, vbTextCompare)
          If lnTextStart >= (StartPosition + Len(StartText)) And lnTextEnd > lnTextStart Then
              GetStringBetween = Mid$(InputText, lnTextStart, lnTextEnd - lnTextStart)
          Else
              GetStringBetween = ""
          End If
    End Function
    Public Function Rand(ByVal Low As Long, _
    ByVal High As Long) As Long
    Randomize
    Rand = Int((High - Low + 1) * Rnd) + Low
    End Function
    
    Private Sub cmdclear_Click()
    lstaccounts.Clear
    End Sub
    
    Private Sub cmdclearitems_Click()
    lstitems.Clear
    End Sub
    
    Private Sub cmdload_Click()
    Dim strFile As String
    strFile = SelectFileToLoad(CD)
    If Len(strFile) > 1 Then
    Call FileModule.TextFileToList(strFile, lstaccounts)
    Else
    MsgBox ("No file was loaded!")
    End If
    End Sub
    
    Private Sub cmdloaditems_Click()
    Dim strFile As String
    strFile = SelectFileToLoad(CD)
    If Len(strFile) > 1 Then
    Call FileModule.TextFileToList(strFile, lstitems)
    Else
    MsgBox ("No file was loaded!")
    End If
    End Sub
    
    Private Sub cmdSave_Click()
    Call saveList(lststatus, App.Path & "\" & txtsave.Text & ".txt", "Append")
    
    End Sub
    
    
    Private Sub cmdStart_Click()
    Dim stritem As String
    Dim strunique As String
    Dim strqty As String
    Dim strcheck As String
    Dim strTotalNP As String
    cmdStart.Enabled = False
    cmdstop.Enabled = True
    StopProgram = False
    If StopProgram = False Then
    
    For X = 0 To lstaccounts.ListCount - 1
    strTotalNP = 0
    If StopProgram = False Then
    
    lststatus.AddItem ("=====================================")
    End If
    stringtosplit = lstaccounts.List(X)
    
    temp = Split(stringtosplit, ":")
    'temp(0) = user
    user = temp(0)
    'temp(1) = pass
    pass = temp(1)
    
    stringtosplit = txtproxy.Text
    
    temp = Split(stringtosplit, ":")
    'temp(0) = user
    host = temp(0)
    'temp(1) = pass
    port = temp(1)
    
    If chkProxy.Value = 1 Then
    Call RipperWrapper.SetProxy("" & host, "" & port)
    End If
    If StopProgram = False Then
    
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/")
    lblstatus.Caption = "Logging in."
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    Call RipperWrapper.Request(strHTML, "POST", "http://www.neopets.com/login.phtml?username=" & user & "&password=" & pass & "&destination=%2petcentral.phtml/")
    If InStr(1, strHTML, "badpassword") Then
    lststatus.AddItem ("Account " & user & "had the wrong password.")
    lblstatus.Caption = "Invalid Password/Username"
    ElseIf InStr(1, strHTML, "This account has been") Then
    lststatus.AddItem ("Account " & user & "has been frozen.")
    lblstatus.Caption = "Sorry, This Account Has Been Frozen"
    ElseIf InStr(1, strHTML, "Update Account") Then
    lststatus.AddItem ("Account " & user & " needs to be updated.")
    lblstatus.Caption = "Sorry, This Account Has Been Lawyerbotted"
    ElseIf InStr(1, strHTML, "It looks like you haven't logged in for a while") Then
    lststatus.AddItem ("Account " & user & " needs to be Bday cracked.")
    lblstatus.Caption = "Sorry, This Account Hasn't Been Logged in"
    ElseIf InStr(1, strHTML, "petcentral") Then
    lblstatus.Caption = "Successfully logged in."
    End If
    If chkProxy.Value = 1 Then
    Call RipperWrapper.NoProxy
    End If
    If StopProgram = False Then
    lststatus.AddItem ("Checking account: " & user)
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/userlookup.phtml?user=" & user)
    'vbKeyTab is for tabs
    strcheck = GetStringBetween(strHTML, "<b>Secret Avatars:</b><br />", "<br /><br /><br />")
    strcheck = Replace(strcheck, vbKeyTab, "")
    lststatus.AddItem ("Account has " & strcheck & " avatars.")
    
    strcheck = GetStringBetween(strHTML, "<b>Stamps:</b><br />", "<br /><br />")
    strcheck = Replace(strcheck, vbKeyTab, "")
    lststatus.AddItem ("Account has " & strcheck & " stamps.")
    
    strcheck = GetStringBetween(strHTML, "<b>Site Themes:</b><br />", "</td>")
    strcheck = Replace(strcheck, vbKeyTab, "")
    lststatus.AddItem ("Account has " & strcheck & " site themes.")
    
    Call GBA(strHTML, "http://images.neopets.com/trophies", ".gif", lstGBA)
    lststatus.AddItem (" Account has " & lstGBA.ListCount & " trophies.")
    
    
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    
    lblstatus.Caption = "Checking Bank."
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/bank.phtml")
    strcheck = GetStringBetween(strHTML, "<td align=""center"" style=""font-weight: bold;"">", " NP</td>")
    lststatus.AddItem ("Account has " & strcheck & " NP in bank.")
    
    strMyNeopoints = GetStringBetween(strHTML, "objects.phtml?type=inventory"">", "</a>")
    lststatus.AddItem ("Account has " & strMyNeopoints & " NP on hand.")
    strcheck = Replace(strcheck, ",", "")
    strMyNeopoints = Replace(strMyNeopoints, ",", "")
    
    strTotalNP = Val(strTotalNP) + Val(strMyNeopoints) + Val(strcheck)
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/safetydeposit.phtml")
    strcheck = GetStringBetween(strHTML, "Items:</b> ", " | <b>Qty:</b>")
    strqty = GetStringBetween(strHTML, " | <b>Qty:</b>", vbNewLine)
    lststatus.AddItem ("Account has " & strcheck & " unique items and " & strqty & " total items in SDB.")
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/safetydeposit.phtml")
    strcheck = GetStringBetween(strHTML, "<b>Items:</b> ", " | <b>Qty:</b>")
    strqty = GetStringBetween(strHTML, " | <b>Qty:</b>", " | <b>Page:</b>")
    lststatus.AddItem ("Account has " & strcheck & " unique items and " & strqty & " total items in closet.")
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    
    Call RipperWrapper.Request(strHTML, "GET", "http://www.neopets.com/quickref.phtml")
    lststatus.AddItem ("Now checking pets.")
    If InStr(strHTML, "must be converted in order to be fully customisable.") Then
    lststatus.AddItem ("Account has unconverted pets!!")
    End If
    Call GBA(strHTML, "Species:</th><td class='sf'><b>", "</b></td></tr>", lstspecies)
    Call GBA(strHTML, "Colour:</th><td class='sf'><b>", "</b></td></tr>", lstcolour)
    Call GBA(strHTML, "Level:</th><td class='sf'><b>", "</b></td></tr>", lstlvl)
    Call GBA(strHTML, " / ", "</b>", lsthealth)
    Call GBA(strHTML, "Strength:</th><td class='sf'><b>", "</b></td></tr>", lststrength)
    Call GBA(strHTML, "Defence:</th><td class='sf'><b>", "</b></td></tr>", lstdefence)
    Call GBA(strHTML, "Move:</th><td class='sf'><b>", "</b></td></tr>", lstmove)
    For i = 0 To lstspecies.ListCount - 1
    lststatus.AddItem ("Pet #" & i & " statistics:")
    lststatus.AddItem ("Species: " & lstspecies.List(i))
    lststatus.AddItem ("Colour: " & lstcolour.List(i))
    lststatus.AddItem ("Level: " & lstlvl.List(i))
    lststatus.AddItem ("Max Health: " & lsthealth.List(i))
    lststatus.AddItem ("Strength: " & lststrength.List(i))
    lststatus.AddItem ("Defence: " & lstdefence.List(i))
    lststatus.AddItem ("Move: " & lstmove.List(i))
    lststatus.AddItem ("------------------------")
    
    Next i
    lstspecies.Clear
    lstcolour.Clear
    lstlvl.Clear
    lsthealth.Clear
    lststrength.Clear
    lstdefence.Clear
    lstmove.Clear
    MSToWait (Rand(txtwait1.Text, txtwait2.Text))
    
    
    
    
    lststatus.AddItem ("Account has " & strTotalNP & " total NP.")
    End If
    
    Else
    If StopProgram = False Then
    
    lblstatus.Caption = "Error is Unknown"
    lststatus.AddItem ("Account " & user & "has an unknown error.")
    End If
    End If
    
    
    Next X
    End If
    lblstatus.Caption = "Idle..."
    End Sub
    
    Private Sub cmdstop_Click()
    StopProgram = True
    lblstatus.Caption = "Stopped."
    cmdStart.Enabled = True
    cmdstop.Enabled = False
    End Sub
    
    Private Sub Command1_Click()
    stringtosplit = txtproxy.Text
    
    temp = Split(stringtosplit, ":")
    'temp(0) = user
    host = temp(0)
    'temp(1) = pass
    port = temp(1)
    If chkProxy.Value = 1 Then
    Call RipperWrapper.SetProxy("" & host, "" & port)
    End If
    Call RipperWrapper.Request(strHTML, "GET", "http://www.whatismyproxy.com/")
    strHTML = GetStringBetween(strHTML, "Your visible IP address: ", "</h1><h3>")
    MsgBox ("Proxy IP is: " & strHTML)
    Call RipperWrapper.NoProxy
    Call RipperWrapper.Request(strHTML, "GET", "http://www.whatismyproxy.com/")
    strHTML = GetStringBetween(strHTML, "Your visible IP address: ", "</h1><h3>")
    MsgBox ("Regular IP is: " & strHTML & vbNewLine & "(c) http://www.whatismyproxy.com/")
    
    End Sub
    
    Private Sub Command2_Click()
    Dim nowdate As Date
    txtsave.Text = DateValue(Now)
    txtsave.Text = Replace(txtsave.Text, "/", "-")
    End Sub
    
    Private Sub Form_Load()
    txtsave.Text = DateValue(Now)
    txtsave.Text = Replace(txtsave.Text, "/", "-")
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    Call saveList(lststatus, App.Path & "\ProgLog.txt", "Append")
    Dim frm As Form
    For Each frm In Forms
     Unload frm
    Next
    
    End Sub
    
    Private Sub txtproxy_Click()
    txtproxy.Text = ""
    End Sub
    Here's some good links that might not be in the source:
    Code:
    Bank http://www.neopets.com/bank.phtml **
    Safety Deposit Box http://www.neopets.com/safetydeposit.phtml
    Closet http://www.neopets.com/closet.phtml
    Petpets http://www.neopets.com/quickref.phtml
    Battledome http://www.neopets.com/battledome/battledome.phtml?type=equip
    Neocash Items http://www.neopets.com/ncma/
    Inventory http://www.neopets.com/objects.phtml?type=inventory
    Shop http://www.neopets.com/market.phtml?type=your
    Shop Till http://www.neopets.com/market.phtml?type=till
    Gallery http://www.neopets.com/gallery/index.phtml?gu=USERNAME
    Neodeck http://www.neopets.com/games/neodeck/index.phtml
    Stock Market http://www.neopets.com/stockmarket.phtml?type=portfolio
    Storage Shed http://www.neopets.com/stockmarket.phtml?type=portfolio
    Neohome Items http://www.neopets.com/neohome.phtml?type=item_list
    Neggery http://www.neopets.com/winter/neggery.phtml
    Laboratory http://www.neopets.com/lab.phtml
    Keyquest http://www.neopets.com/keyquest/vault/
    Rainbow Fountain (FFQ) http://www.neopets.com/faerieland/rainbowfountain.phtml
    World Challenge http://www.neopets.com/challenges/world_index.phtml
    TCG Album http://www.neopets.com/tcg/album.phtml
    Unused Plot Points (Return of Sloth) http://www.neopets.com/space/ros/prizes.phtml
    Unused Plot Points (Tale of Woe) http://www.neopets.com/halloween/hwp/shack.phtml
    Unused Plot Points (Lost Desert) http://www.neopets.com/desert/ldp/gift_shop.phtml
    Unused Plot Points (Altador Cup) http://www.neopets.com/altador/colosseum/2011/prizes.phtml
    Unused Plot Points (The Faeries' Ruin)http://www.neopets.com/faerieland/tfr/prizes.phtml

  2. The Following 2 Users Say Thank You to Reemer For This Useful Post:

    j03 (12-02-2018),RealisticError (10-29-2018)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •