این کد کامل لاگین کردن هستش که به صورت کامل ایدی رو لاگین می کنه الان برای این چطوری یه pm سندر بنویسم خواهشا از کد های دیگه کپی نکنین چون کار نمیکنه
Public StrYcook As String
Public StrTcook As String
Public BotID As String
Dim Out1 As String
Dim Out2 As String
Private Sub Command1_Click()
BotID = id.Text
Winsock1.Close
Winsock1.Connect "login.yahoo.com", "80"
End Sub
Private Sub Winsock1_Connect()
On Error Resume Next
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
Winsock1.Close
Debug.Print "Yahoo! - 400 Bad Request"
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
Debug.Print "connect to port 80"
Winsock1.Close
Winsock2.Close
Winsock2.Connect "mcs.msg.yahoo.com", 5050
Else:
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)
Debug.Print "number=" & Number & "des=" & Description
End Sub
Private Sub Winsock2_Connect()
On Error Resume Next
Winsock2.SendData Login(BotID, StrYcook, StrTcook)
Me.Caption = "Please Wait Chat Bot.."
End Sub
Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim Data As String
Dim cas As String
Winsock2.GetData Data
cas = Asc(Mid(Data, 12, 1))
'
Select Case Asc(Mid(Data, 12, 1))
'
Case 168
If InStr(Data, "samaneh_lalala_o3") Then
Dim sss As String
sss = Data
End If
Case 75
Dim InstanseIdType As String
InstanseIdType = Split(Data, "4À€")(1)
InstanseIdType = Split(InstanseIdType, "À€5À€")(0)
Me.Caption = InstanseIdType & " typed message for you"
'
Case 6
Dim InstanseMsgPm As String
Dim InstanseIdPm As String
InstanseIdPm = Split(Data, "4À€")(1)
InstanseIdPm = Split(InstanseIdPm, "À€5À€")(0)
InstanseMsgPm = Split(Data, "14À€")(1)
InstanseMsgPm = Split(InstanseMsgPm, "À€63")(0)
Me.Caption = InstanseIdPm
Text1.Text = InstanseMsgPm
'
Case 85
Me.Caption = "Logged in"
Debug.Print "Logged in"
blnconnected = True
'
Case 2
If InStr(Data, "ÿÿÿÿ") Then
Me.Caption = "Logged Out By Server"
blnconnected = False
Winsock2.Close
End If
'
Case 117
Data1 = Split(Data, "À€109À€")
On Error Resume Next
For i = 1 To 60
List1.AddItem Split(Data1(i), "À€")(0)
Next i
Case Is = 150
'if allowed sends join chatroom
Winsock2.SendData chatjoin(id.Text, Chatroom.Text)
Case Is = 152
If InStr(Data, "To help prevent") > 0 Then
Out1 = Split(Data, "chatting")(1)
Out1 = Mid(Out1, 3, Len(Out1))
Out1 = Split(Out1, "À€108À€2À€109À€")(0)
Out2 = Split(Out1, "img=")(1)
Out2 = Split(Out2, ".jpg")(0)
Out2 = Out2 & ".jpg"
WebBrowser1.Navigate Out2
ElseIf InStr(Data, "114À€-35À€") > 0 Then
Me.Caption = "Room is full"
Winsock3.Close
Winsock3.Connect "captcha.chat.yahoo.com", 80
ElseIf InStr(Data, "À€128À€") > 0 Then
If InStr(Data, "À€109À€") > 0 Then
Data1 = Split(Data, "À€109À€")
On Error Resume Next
For i = 1 To 60
List1.AddItem Split(Data1(i), "À€")(0)
Next i
End If
End If
Debug.Print Data
Text1.Text = Text1.Text & Chr(13) & Data
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)
Debug.Print Description, vbCritical
Winsock2.Close
End Sub
Public Function Login(YahooID As String, YCookie As String, TCookie As String)
Login = Header("0" & YahooID & "2" & YahooID & "1" & YahooID & "24416" & YCookie & " " & TCookie & "98us", String(4, Chr(0)), String(4, Chr(0)), 550)
End Function
Public Function chatjoin(YahooID As String, Chatroom As String)
If Chatroom = vbNullString Then
chatjoin = Header("109" & YahooID & "1" & YahooID & "6abcde98us1359.0.0. 2152", String(4, Chr(0)), String(4, Chr(0)), 150)
Else
chatjoin = Header("1À€" & YahooID & "À€104À€" & Chatroom & "À€129À€" & "À€62À€2À€", String(4, Chr(0)), String(4, Chr(0)), 152)
End If
End Function
Private Sub captchaword_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Winsock3.Close
Winsock3.Connect "captcha.chat.yahoo.com", 80
End If
End Sub
Public Function captchasend(CaptImg As String, CaptWord As String, CaptCookie As String) As String
Dim pck As String, StrCap As String
On Error Resume Next
pck = "question=" & CaptImg & "&.intl=us&answer=" & CaptWord
StrCap = "POST http://captcha.chat.yahoo.com/captcha1 HTTP/1.1" & vbCrLf
StrCap = StrCap + "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, */*" & vbCrLf
StrCap = StrCap + "Referer: http://captcha.chat.yahoo.com" & vbCrLf
StrCap = StrCap + "Accept-Language: en-us" & vbCrLf
StrCap = StrCap + "Content-Type: application/x-www-form-urlencoded" & vbCrLf
StrCap = StrCap + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)" & vbCrLf
StrCap = StrCap + "Host: captcha.chat.yahoo.com" & vbCrLf
StrCap = StrCap + "Content-Length: " & Len(pck) & vbCrLf
StrCap = StrCap + "Connection: Keep-Alive" & vbCrLf
StrCap = StrCap + "Cache-Control: no-cache" & vbCrLf
StrCap = StrCap + "Cookie: " & Replace(CaptCookie, "&lang=en", "") & vbCrLf & vbCrLf & pck
captchasend = StrCap
End Function
Private Function YTunnel(Whofrom As String, Whoto As String) As String
Dim pck As String
pck = "1À€" & Whofrom & "À€302À€240À€300À€240À€7À€" & Whoto & "À€224À€" & String(1000, Chr$(181)) & "À€264À€" & String(1000, Chr$(164)) & "À€301À€240À€303À€240À€"
h = Chr$(69) + Chr$(55)
YTunnel = Header(pck, String(4, 0), String(4, 0), 124)
End Function
Public 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 = 102
'
Header = "YMSG" & Chr(Int(Version / 256)) & Chr(Int(Version Mod 256)) & Chr(Int(409 / 256)) & Chr(Int(409 Mod 256)) & 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
Private Sub btnbot_Click()
'Winsock2.SendData fagboy(Id.Text, txtWhoto.Text)
Dim msg As String
msg = txtWhoto.Text
Winsock2.SendData YRoomText(id.Text, Chatroom.Text, msg)
End Sub
Private Function Assemble(ByVal iService As Integer, ByVal iPacket As String) As String
Dim Data As String
Data = "YMSG" & Chr(Int(102 / 256))
Data = Data & Chr(Int(102 Mod 256))
Data = Data & Chr(Int(409 / 256)) & Chr(Int(409 Mod 256))
Data = Data & Chr(Int(Len(iPacket) / 256))
Data = Data & Chr(Int(Len(iPacket) Mod 256))
Data = Data & Chr(Int(iService / 256))
Data = Data & Chr(Int(iService Mod 256))
Data = Data & String(8, Chr(0))
Data = Data & iPacket
'
Assemble = Data
' Debug.Print Assemble
End Function
نوشته شده توسط سید حمید حق پرست
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول