اینم واسه آنلاین چکر، چک کردن Online - Offline - Invisible بودن آیدی یاهو 
'Invisible Checker
ElseIf Left(message, 8) = "/checker" Then
Dim TMPCheck
TMPCheck = Split(message, " ")
If (UBound(TMPCheck) = 1) And (Len(message) > 11) Then
FrmONCheck.txtUser.Text = TMPCheck(1)
UserYahooID = PersonId
FrmONCheck.CheckUSEROnline
Exit Sub
Else
Response = "Dastor Ro Eshteba Zadi Bayad Bezani /Checker ID"
End If
'---------------------------------------------------
'Project Description : Robo Y!Invisible Checker
'Website : Www.Moein-Moghadam.TK
'---------------------------------------------------
Option Explicit
Public blnconnected As Boolean
Public blnchecking As Boolean
Public BotID As String
Public StrYcook As String
Public StrTcook As String
Dim S As String
Dim S2 As String
Dim Perm As Boolean
Private Sub Command1_Click()
On Error Resume Next
If blnconnected = False Then
BotID = ID.Text
Winsock1.Close
Winsock1.Connect "login.yahoo.com", "80"
Else:
Exit Sub
End If
End Sub
Private Sub Command2_Click()
On Error Resume Next
Status.Caption = "Logged Out"
Winsock2.Close
blnconnected = False
End Sub
Private Sub Command3_Click()
On Error Resume Next
If blnconnected = False Then
Exit Sub
End If
'
blnchecking = True
Winsock2.sendData CheckUSER(BotID, txtUser.Text)
Status.Caption = "Checking User"
Pause (2)
'
If Status.Caption = "Checking User" Then
Status.Caption = "User Online"
blnchecking = False
End If
End Sub
Public Sub CheckUSEROnline()
S = ""
S2 = ""
Perm = True
Timer2.Enabled = True
YID = True
Dim StatVar
If Inet1.StillExecuting Then Exit Sub
DoEvents
StatVar = Inet1.OpenURL("http://opi.yahoo.com/online?u=" & txtUser & "&m=j")
DoEvents
S = ""
If InStr(StatVar, "NOT ONLINE") Then
S = "N"
ElseIf InStr(StatVar, "ONLINE") Then
S = "Y"
Else
End If
Text1 = StatVar
If blnconnected = False Then
SendCheck ("BAD")
Status.Caption = "ERRoR"
Exit Sub
End If
'
blnchecking = True
Winsock2.sendData CheckUSER(BotID, txtUser.Text)
Status.Caption = "Checking..."
'
Pause2 (2)
S2 = "N"
Timer1.Enabled = True
End Sub
Private Sub Command4_Click()
CheckUSEROnline
End Sub
Private Sub Command5_Click()
FrmONCheck.Hide
End Sub
Private Sub Form_Load()
On Error Resume Next
CboYmsg.Text = "15"
CboPort.Text = "5050"
CboServers.Text = "scs.msg.yahoo.com"
Perm = False
YID = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Unload Me
End Sub
Private Sub ID_DblClick()
On Error Resume Next
ID.Text = vbNullString
End Sub
Private Sub Pass_DblClick()
On Error Resume Next
Pass.Text = vbNullString
End Sub
Private Sub Timer1_Timer()
If YID = True Then
Status.Caption = "User Online"
blnchecking = False
S2 = "Y"
End If
If S2 = "Y" And S = "N" Then
Status.Caption = "User Invisible"
SendCheck ("IN")
Timer2.Enabled = False
GoTo ee
End If
If S2 = "Y" Then
SendCheck ("ON")
Timer2.Enabled = False
End If
ee:
Timer1.Enabled = False
End Sub
Private Sub Timer2_Timer()
SendCheck ("BAD")
Status.Caption = "BAD"
Timer2.Enabled = False
End Sub
Private Sub Winsock1_Connect()
On Error Resume Next
Status.Caption = "Connecting"
'
Dim LoginYahoo As String
'
LoginYahoo = "GET http://login.yahoo.com/config/login?login=" & ID.Text & "&passwd=" & Pass.Text & " HTTP/1.1" & vbCrLf
LoginYahoo = LoginYahoo & "Accept-Language: en-us" & vbCrLf
LoginYahoo = LoginYahoo & "User-Agent: Mozilla/5.0 (compatible; MSIE 8.0; Windows NT 5.1; Expulsion-Creations)" & vbCrLf
LoginYahoo = LoginYahoo & "Accept: */*" & vbCrLf
LoginYahoo = LoginYahoo & "Host: login.yahoo.com" & vbCrLf
LoginYahoo = LoginYahoo & "Connection: Keep-Alive" & vbCrLf & vbCrLf
'
Winsock1.sendData LoginYahoo
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim Data As String
'
Winsock1.getData Data
'
If InStr(Data, "Yahoo! - 400 Bad Request") Then
Status.Caption = "Bad ID"
Winsock1.Close
Exit Sub
Else:
If InStr(Data, "302 Found") Then
StrYcook = Split(Data, "Y=")(1)
StrYcook = Split(StrYcook, "np=1")(0)
StrYcook = "Y=" & StrYcook & "np=1;"
StrTcook = Split(Data, "T=")(1)
StrTcook = Split(StrTcook, ";")(0)
StrTcook = "T=" & StrTcook
Winsock1.Close
Winsock2.Close
Winsock2.Connect CboServers.Text, CboPort.Text
Else:
Status.Caption = "Bad Password"
Exit Sub
End If
End If
End Sub
Private Sub Winsock1_Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Status.Caption = Description
End Sub
Private Sub Winsock2_Connect()
On Error Resume Next
Winsock2.sendData Login2(BotID, StrYcook, StrTcook)
End Sub
Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
'On Error Resume Next
Dim Data As String
Winsock2.getData Data
Select Case Asc(Mid(Data, 12, 1))
'
Case 85
Status.Caption = "Logged in"
blnconnected = True
'
Case 2
If InStr(Data, "ÿÿÿÿ") Then
Status.Caption = "Logged Out By Server"
blnconnected = False
Winsock2.Close
End If
'
Case 79
If blnchecking = True And _
InStr(Data, "À€11À€0À€") Then
YID = False
SendCheck ("F")
Status.Caption = "User Offline"
Timer1.Enabled = False
Timer2.Enabled = False
blnchecking = False
End If
'
End Select
End Sub
Private Sub Winsock2_Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Status.Caption = Description
End Sub
Option Explicit
Public YID As Boolean
Public UserTOCheck As String
Public UserYahooID As String
Private Function Header(ByVal StrPacketType As String, ByVal StrStat As String, ByVal StrSession As String, ByVal StrComm As Long) As String
Dim Version As String
'
Version = FrmONCheck.CboYmsg.Text
'
Header = "YMSG" & Chr(Int(Version / 256)) & Chr(Int(Version Mod 256)) & String(2, Chr(0)) & Chr(Int(Len(StrPacketType) / 256)) & Chr(Int(Len(StrPacketType) Mod 256)) & Chr(Int(StrComm / 256)) & Chr(Int(StrComm Mod 256)) & Mid(StrStat, 1, 4) & Mid(StrSession, 1, 4) & StrPacketType
End Function
Public Function Login2(YahooID As String, YCookie As String, TCookie As String)
Login2 = Header("0" & YahooID & "2" & YahooID & "1" & YahooID & "24416" & YCookie & " " & TCookie & "98us", String(4, Chr(0)), String(4, Chr(0)), 550)
End Function
Public Function CheckUSER(whofrom As String, Whoto As String) As String
On Error Resume Next
Dim Packet As String
Packet = Header("1" & whofrom & "4" & whofrom & "12" & "Blahblah" & "==" & "61025" & Whoto & "13049PEERTOPEER", String(4, Chr(0)), String(4, Chr(0)), 79)
CheckUSER = Packet
End Function
Public Sub Pause2(Interval)
On Error Resume Next
Dim Delay
'
Delay = Timer
Do While Timer - Delay < val(Interval)
DoEvents
Loop
End Sub
Public Sub SendCheck(Status As String)
Dim S As String
If Status = "IN" Then
S = "<black>ID <b><red>" & FrmONCheck.txtUser.Text & " </b><green>Dar Halate Makhfi <black>Gharar Darad :-j"
End If
If Status = "ON" Then
S = "<black>ID <b><red>" & FrmONCheck.txtUser.Text & " </b><green>Online <black>Mibashad ;;)"
End If
If Status = "F" Then
S = "<black>ID <b><red>" & FrmONCheck.txtUser.Text & " </b><green>Offline <black>Mibashad i-)"
End If
If Status = "BAD" Then
S = "<black><b>Dar Hale Hazer Ghat Zadam Va Nemitonam Tashkhis Bedam :(</b>"
End If
sendData SendPm(frmMain.tUser.Text, UserYahooID, S)
End Sub
دوستان عزیز در مورد امکانات برای روبات هرگونه سوال، نظر، پیشنهاد و . . . داشتید برام پیغام خصوصی ارسال کنید.
امکاناتی از جمله:
دیکشنری آنلاین، بوتر آنلاین، آنلاین چکر و . . . . . . . . ..... ..... ..... . . . ...... ..... ..... . . . . . . . . 
امکانات برای روبات
پاسخ با نقل قول
نوشته شده توسط niksalehi
