Rip, steal, improve, learn, or hell, even go cake to it if you want. I don't give a cake. I am not explaining or annotating shit. Well, if you really want to then contact me on msn. Credits to CheeSie for fixing and Zach for his InstrB code. Note: Some code is in the login of this program. Some is also in a module. Code (Text): Private Declare Function SendMessageByNum Lib "user32" _ Alias "SendMessageA" (ByVal hwnd As Long, ByVal _ wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Const LB_SETHORIZONTALEXTENT = &H194 Dim strPage As String, strPetpet As String, strMootix As String, PetCount As Integer, HTML As String Dim nid As NOTIFYICONDATA2 Public Function GB(rC As String, rS As String, rF As String, Optional lgB As Long = 1) As String On Error Resume Next lgB = InStr(lgB, rC, rS) + Len(rS): GB = Mid$(rC, lgB, InStr(lgB, rC, rF) - lgB) End Function Public Function SaveList(ByVal strPrintToFile As String, _ ByRef lstFormList As ListBox, Optional ByVal blnClearList As Boolean = False) Dim i As Long 'longs are quicker than Integers so I normally use those Dim FN As Integer FN = FreeFile 'print each line in the list to a new text file Open strPrintToFile For Output As #FN 'Add all Items to the opened file For i = 0 To lstFormList.ListCount - 1 Print #FN, lstFormList.List(i) Next i Close #FN 'thats it... your file is updated End Function Public Function ExtractAll(SearchString As String, StartString As String, EndString As String, AddToList As ListBox) As String Dim Temp As Long, temp1 As Long, temp2 As Long, temp3 As Long temp1 = 1 Do While InStr(temp1, SearchString, StartString, vbTextCompare) <> 0 Temp = InStr(temp1, SearchString, StartString, vbTextCompare) + Len(StartString) temp2 = InStr(Temp, SearchString, EndString, vbTextCompare) temp3 = temp2 - Temp temp1 = temp2 + 1 AddToList.AddItem (Mid$(SearchString, Temp, temp3)) Loop End Function Public Function FileExists(Filename As String) As Boolean FileExists = (Dir(Filename) <> "") End Function Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim msg As Long Dim sFilter As String msg = X / Screen.TwipsPerPixelX Select Case msg Case WM_LBUTTONDOWN2 Me.Show ' show form Shell_NotifyIcon NIM_DELETE2, nid ' del tray icon Case WM_LBUTTONUP2 Case WM_LBUTTONDBLCLK2 Case WM_RBUTTONDOWN2 Case WM_RBUTTONUP2 Me.Show Shell_NotifyIcon NIM_DELETE2, nid Case WM_RBUTTONDBLCLK2 End Select End Sub Sub minimize_to_tray() Me.Hide nid.cbSize = Len(nid) nid.hwnd = Me.hwnd nid.uID = vbNull nid.uFlags = NIF_ICON2 Or NIF_TIP2 Or NIF_MESSAGE2 nid.uCallbackMessage = WM_MOUSEMOVE2 nid.hIcon = Me.Icon nid.szTip = "Violent_J's PetPet Adopter" & vbNullChar Shell_NotifyIcon NIM_ADD2, nid End Sub Sub lstAddHScroll(lst As ListBox) ' depends on the scalewidth ' if scalemode is Twips then Divide M by 15 to get Pixels For a = 0 To lst.ListCount - 1 If Me.TextWidth(lst.List(a)) > m Then m = Me.TextWidth(lst.List(a)) Next SendMessageByNum lst.hwnd, LB_SETHORIZONTALEXTENT, m / 15, 0 End Sub Private Sub chkcolor_Click() If chkcolor.Value = Checked Then chkgrabanypetpet.Enabled = False: chkgrabanypetpet.Value = Unchecked If chkcolor.Value = Unchecked Then chkgrabanypetpet.Enabled = True End Sub Private Sub chkname_Click() If chkname.Value = Checked Then chkgrabanypetpet.Enabled = False: chkgrabanypetpet.Value = Unchecked If chkname.Value = Unchecked Then chkgrabanypetpet.Enabled = True End Sub Private Sub cmdadd2_Click() lstpetpetcolors.AddItem InputBox("Please type in the petpet color you wish to add!", "Add Petpet Color", "Input Petpet Color here") End Sub Private Sub cmdclear2_Click() lstpetpetcolors.Clear End Sub Private Sub cmdload2_Click() Dim strFile As String strFile = Functions.SelectFileToLoad(CD) If Len(strFile) > 1 Then Call Functions.TextFileToList(strFile, lstpetpetcolors) Else MsgBox "Please select a file to load!", vbInformation, "Load List Failure" End If End Sub Private Sub cmdmin_Click() Call minimize_to_tray End Sub Private Sub cmdremove2_Click() strOb = lstpetpetcolors.ListCount Do While strOb > 0 strOb = strOb - 1 If lstpetpetcolors.Selected(strOb) = True Then lstpetpetcolors.RemoveItem (strOb) End If Loop End Sub Private Sub cmdsave2_Click() CD.DialogTitle = "Save Listbox" CD.InitDir = App.Path CD.Flags = &H4 CD.Filter = "Text Files (*.txt)|*.txt" CD.ShowSave Call xSaveList(CD.Filename, lstpetpetcolors) End Sub Private Sub Form_Load() If frmLogin.chkproxy.Value = Checked Then frmmain.w.SetProxy frmLogin.txthost.Text & ":" & frmLogin.txtport.Text End If If FileExists(App.Path & "\Avatar Petpets.txt") = True Then Call Functions.TextFileToList(App.Path & "\Avatar Petpets.txt", lstpetpets) If FileExists(App.Path & "\ListOfPetpetColors.txt") = True Then Call Functions.TextFileToList(App.Path & "\ListOfPetpetColors.txt", lstpetpetcolors) End If End If End Sub Private Sub chkgrabanypetpet_Click() If chkgrabanypetpet.Value = Checked Then chkcolor.Value = Unchecked: chkcolor.Enabled = False: chkname.Enabled = False If chkgrabanypetpet.Value = Unchecked Then chkcolor.Enabled = True: chkname.Enabled = True End Sub Private Sub cmdAdd_Click() lstpetpets.AddItem InputBox("Please type in the petpet you wish to add!", "Add Petpet", "Input Petpet name here") End Sub Private Sub cmdclearchk_Click() lstbad.Clear End Sub Private Sub cmdclearpetpets_Click() lstpetpets.Clear End Sub Private Sub cmdload_Click() Dim strFile As String strFile = Functions.SelectFileToLoad(CD) If Len(strFile) > 1 Then Call Functions.TextFileToList(strFile, lstpetpets) Else MsgBox "Please select a file to load!", vbInformation, "Load List Failure" End If End Sub Private Sub cmdremove_Click() strOb = lstpetpets.ListCount Do While strOb > 0 strOb = strOb - 1 If lstpetpets.Selected(strOb) = True Then lstpetpets.RemoveItem (strOb) End If Loop End Sub Private Sub cmdsavelog_Click() CD.DialogTitle = "Save Listbox" CD.InitDir = App.Path CD.Flags = &H4 CD.Filter = "Text Files (*.txt)|*.txt" CD.ShowSave Call xSaveList(CD.Filename, lstlog) End Sub Private Sub cmdsavepetpets_Click() CD.DialogTitle = "Save Listbox" CD.InitDir = App.Path CD.Flags = &H4 CD.Filter = "Text Files (*.txt)|*.txt" CD.ShowSave Call xSaveList(CD.Filename, lstpetpets) End Sub Private Sub cmdstart_Click() SendMessageByNum lstlog.hwnd, LB_SETHORIZONTALEXTENT, 400, 0 cmdstop.Enabled = True cmdstart.Enabled = False tmrgo.Enabled = True lstlog.AddItem Time & " : Program Started!", 0 lblstatus.Caption = "Sniping..." tmrgo.Interval = Int(Math.Rnd() * ((txty + 1) - txtx) + txtx) Text1.Text = frmLogin.PetCount2 End Sub Private Sub cmdstop_Click() tmrgo.Enabled = False lblstatus.Caption = "Idle..." cmdstart.Enabled = True cmdstop.Enabled = False lstlog.AddItem Time & " : Program Stopped!", 0 End Sub Private Sub cmdupdate_Click() cmdupdate.Enabled = False lblstatus.Caption = "Updating Account Stats!" lstlog.AddItem Time & " : Updating account stats!", 0 HTML = frmmain.w.Request("GET", "http://www.neopets.com/index.phtml/") If InStrB(1, HTML, ">»</span> Customise</b></a></td>") Then cmdupdate.Enabled = True lblstatus.Caption = "Idle..." lstlog.AddItem Time & " : Updated account stats!", 0 frmmain.lbluser.Caption = GB(HTML, "/userlookup.phtml?user=", "" & ChrW$(34) & ">") frmmain.lblpet.Caption = GB(HTML, "<a href=" & ChrW$(34) & "/quickref.phtml" & ChrW$(34) & "><b>", "</b></a>") frmmain.lblNP.Caption = GB(HTML, "/objects.phtml?type=inventory" & ChrW$(34) & ">", "</a>") Else frmmain.lbluser.Caption = GB(HTML, "/userlookup.phtml?user=", "" & ChrW$(34) & ">") frmmain.lblpet.Caption = "None" frmmain.lblNP.Caption = GB(HTML, "/objects.phtml?type=inventory" & ChrW$(34) & ">", "</a>") cmdupdate.Enabled = True lblstatus.Caption = "Idle..." lstlog.AddItem Time & " : Updated account stats!", 0 End If End Sub Private Sub tmrgo_Timer() Dim i As Integer If frmLogin.PetCount2 > 3 Then lstlog.AddItem Time & " : Account has 4 pets!", 0 cmdstop_Click lblstatus.Caption = "Idle..." If optshutdown.Value = True Then Unload Me End If pound: tmrgo.Interval = Int(Math.Rnd() * ((txty + 1) - txtx) + txtx) lblstatus.Caption = "Sniping..." lstpets.Clear ExtractAll w.Request("GET", "http://www.neopets.com/pound/adopt.phtml", "http://www.neopets.com/pound/index.phtml"), ".name = """, """;", lstpets For i = 0 To lstpets.ListCount - 1 If cmdstop.Enabled = False Then i = lstpets.ListCount If InStrLB(lstbad, lstpets.List(i)) Then lblstatus.Caption = "Already searched for " & lstpets.List(i) lstlog.AddItem Time & " : Already searched for " & lstpets.List(i) Else strPage = w.Request("GET", "http://www.neopets.com/petlookup.phtml?pet=" & lstpets.List(i)) strPetpet = GB(strPage, "</b> the ", "<br />") txtpetpet.Text = strPetpet If InStrB(1, strPage, "does not have a Petpet.") Then lstlog.AddItem Time & " : " & lstpets.List(i) & " does not meet criteria!", 0 GoTo SkipAdopt ElseIf chkmootix.Value = Checked And InStrB(1, strPage, " and its <b>Mootix") Then lstlog.AddItem " : Found pet with mootix, trying to adopt!", 0 GoTo Adopt ElseIf chkzap.Value = Checked And InStrB(1, strPage, "http://images.neopets.com/games/petpetlab/zapped.gif") Then lstlog.AddItem Time & " : " & lstpets.List(i) & " is zapped so it does not meet criteria!", 0 GoTo pound ElseIf chkgrabanypetpet.Value = Checked And InStrB(1, strPage, " has a Petpet!") Then lstlog.AddItem Time & " : Pet with petpet found, trying to adopt!", 0 GoTo Adopt ElseIf InStrB(1, strPage, lstpetpets) And chkname.Value = Checked Then lstlog.AddItem Time & " : Petpet from Speice list found, trying to adopt", 0 GoTo Adopt ElseIf InStrB(1, strPage, lstpetpetcolors) And chkcolor.Value = Checked Then lstlog.AddItem Time & " : Petpet from Color List found, trying to adopt", 0 GoTo Adopt Else lstlog.AddItem Time & " : " & lstpets.List(i) & " does not meet criteria!", 0 GoTo SkipAdopt End If Adopt: strPage = w.Request("POST", "http://www.neopets.com/pound/process_adopt.phtml?pet_name=" & lstpets.List(i), "http://www.neopets.com/pound/adopt.phtml") strPage = w.Request("GET", "http://www.neopets.com/petlookup.phtml?pet=" & lstpets.List(i)) If InStrB(1, strPage, "(You!)") <> 0 Then frmLogin.PetCount2 = frmLogin.PetCount2 + 1 lblstatus.Caption = "Adopted " & lstpets.List(i) & " with a " & strPetpet lstlog.AddItem Time & " : Adopted " & lstpets.List(i) & " with a " & strPetpet, 0 If chksound.Value = Checked Then Play App.Path & "\sound.wav" If chkpopup.Value = Checked Then frmgotpet.Show If optstop.Value = True Then lblstatus.Caption = "Got " & strPetpet: lstlog.AddItem Time & ": Got " & strPetpet, 0: cmdstop_Click: i = lstpets.ListCount Else lblstatus.Caption = "Could not adopt pet!" lstlog.AddItem Time & " : Failed to adopt " & lstpets.List(i), 0 End If End If SkipAdopt: lstbad.AddItem lstpets.List(i) Next i End Sub Function InStrLB(ByVal lstSearch As ListBox, ByVal sToSearch As String) As Boolean Dim i As Integer For i = 0 To lstSearch.ListCount - 1 If LCase$(lstSearch.List(i)) = LCase$(sToSearch) Then InStrLB = True: Exit Function Next i End Function Private Sub cmdclearlog_Click() lstlog.Clear End Sub Sub UnloadMe() Dim frmTemp As Form For Each frmTemp In Forms Unload frmTemp Set frmTemp = Nothing Next End Sub Private Sub Form_Unload(Cancel As Integer) Shell_NotifyIcon NIM_DELETE, nid Dim frmTemp As Form For Each frmTemp In Forms Unload frmTemp Set frmTemp = Nothing Next End Sub
thank you very much , I ran the code... fixed one thing and it works. If anyone else needs help with the code they can contact me also or post here and I'll try and reply