# Native Code > برنامه نویسی در 6 VB > برنامه نویسی مرتبط با شبکه و وب در VB6 > سوال: ارسال pm با winsock

## movaffag

سلام من با winsock لاگین شدم الان چطوری به یه ایدی مشخص pm بدم

----------


## سید حمید حق پرست

چرا از YMSGMod.OCX استفاده نمیکنی؟
راحتره
با YMSGMod.OCX :
Call YMSG1.PckSendMsg(send2.Text, SendPM.Text)

----------


## movaffag

سوس مربوط به این کامپوننت یا مقاله اموزشی داره؟

----------


## سید حمید حق پرست

اره دوست عزیز اینم سورس :

----------


## movaffag

فقط یه مشکلی که هست من نمی خوام با کامپوننت بنویسم winsock هم چون مال خود ویندوز هست ازش استفاده میکنم

----------


## سید حمید حق پرست

این کدهارو اقای *_behnam_* عزیز تو یه تاپیک گذاشتن :

اینم کدهاش :
یاهو چندین پروتکل داره که فکر کنم ساده تر از همش 102 باشه که از سرعت بالایی هم برخورداره  

 شما به 2 تا وینسوک نیاز دارید البته با یک وینسوک هم میشه اما چون اولشه با 2تا راحت هستی
با وینسوک 1 به یاهو کانکت میشی 
Winsock1.Connect "login.yahoo.com", "80"


وقتی که کانکت شدی باید هدر و بقرستی که ایدی و پسورد هم شاملش میشه 
کد زیر رو وقتی که کانکت شدی با وینسوک ارسال کد

Dim LoginYahoo As String
 LoginYahoo = "GET http://login.yahoo.com/config/login?login=" &<b> ID</b> & "&passwd=" & <b>password </b>& " 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: <b>login.yahoo.com</b>" & vbCrLf
 LoginYahoo = LoginYahoo & "Connection: Keep-Alive" & vbCrLf & vbCrLf
 Winsock1.SendData LoginYahoo




3  وقتی هدر رو ارسال کردی کوکی ها رو دریافت کنی
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
        <b>StrYcook</b> = Split(Data, "Y=")(1)
        <b>StrYcook</b> = Split(<b>StrYcook</b>, "np=1")(0)
        <b>StrYcook</b> = "Y=" & <b>StrYcook</b> & "np=1;"
        <b>StrTcook</b> = Split(Data, "T=")(1)
        <b>StrTcook</b> = Split(<b>StrTcook</b>, ";")(0)
        <b>StrTcook </b>= "T=" & <b>StrTcook</b>
        Debug.Print "connect to port 80"
        Winsock1.Close
        Winsock2.Close
        Winsock2.Connect "mcs.msg.yahoo.com", 5050
    Else:
 msgbox "Error!!"
    Exit Sub
    End If
    End If



خوب اگه آیدی درست باشه  کوکی دریافت میشه و با وینسوک 2 به سرور یاهو وصل میشید برای ارسال پکت ها

واسه ارسال پکت نیاز به یه هدر درست و حسابی داریم! هدرهای زیادی وجود دارن  که بعضی از اونا کامل نیستن و تو دریافت پکت مشکل دارن اینی که قرار میدم  تقریبا کامله من خودم حتی فایل هم از طریق یاهو باش دریافت کردم 
'header
Public Function Header(YMSGPacketData As String, YMSGStatus As String, YMSGKey As String, YMSGCommand As Long) As String
Dim YMSGVendor As Long
Dim YMSGVersion As Integer
YMSGVendor = 0
YMSGVersion = 17
Header = "YMSG" & Chr(Int(YMSGVersion / 256)) & Chr(Int(YMSGVersion Mod 256)) & Chr(Int(YMSGVendor / 256)) & Chr(Int(YMSGVendor Mod 256)) & Chr(Int(Len(YMSGPacketData) / 256)) & Chr(Int(Len(YMSGPacketData) Mod 256)) & Chr(Int(YMSGCommand / 256)) & Chr(Int(YMSGCommand Mod 256)) & Mid(YMSGStatus, 1, 4) & Mid(YMSGKey, 1, 4) & YMSGPacketData
End Function



و حالا یه پکت برای ارسال کوکی و لاگین شدن 
' Send Login
Public Function Login(YahooID As String, YCookie As String, TCookie As String)
    On Error Resume Next
    Dim InVType As String
        InVType = Chr(0)
    Login = Header("0À€" & YahooID & "À€2À€" & YahooID & "À€1À€" & YahooID & "À€244À€" & "0" & "À€6À€" & YCookie & " " & TCookie & "À€98À€usÀ€", String(3, Chr(0)) & InVType, String(3, Chr(0)) & InVType, 550)
End Function



خوب الان ما همه چیرو آماده داریم واسه لاگین شده میتونیم تا Winsock2 کانکت شد باش پکت لاگین رو ارسال کنیم
Winsock2.SendData Login(<b>ID</b>, <b>StrYcook</b>, <b>StrTcook</b>)


الان اگه اطلاعات درست باشن آیدی لاگین میشه

تو قسمت Winsock2_DataArrival  پکت ها دریافت میشن
هر پکت یه شماره مخصوص داره میتونید از شماره پکت ها  مشخص کنید پکت دریافتی چه پکتی هست
Dim Data as string
Dim Types as integer
Winsock2.GetData Data
    Types = Asc(Mid(Data, 12, 1))



اینم کد برای بدست آوردن شماره پکت

میتونید Select case  Types بزارید
برای مثال 
case 6  = دریافت پی ام
case 75   = دریافت تایپینگ
case 85  = لاگین شدن
case 29  = دریافت پی ام های کنفرانس
...

                                                           پایان

موفق باشی


یا علی (ع)

----------


## سید حمید حق پرست

اینم برای فرستادن پی ام :
    sendData SendPm(tUser.Text, txtPersonID.Text, txtMessage.Text)
    txtMessage.Text = ""

----------


## سید حمید حق پرست

سلام

اینم سورس ارسال و دریافت پی ام
موفق باشید

یا علی (ع)

----------


## movaffag

> سلام
> 
> اینم سورس ارسال و دریافت پی ام
> موفق باشید
> 
> یا علی (ع)


این سورس جواب نمیده

----------


## _behnam_

فکرکنم *پروتکل 102* یه مدت هست که *لاگین* نمیشه!

----------


## movaffag

من الان خودم با winsock لاگین می کنم ولی کد ارسال Pm رو ندارم

----------


## _behnam_

*سورس* رو قرار دهید تا در صورت امکان *رسیدگی* بشه

----------


## movaffag

این کد کامل لاگین کردن هستش که به صورت کامل ایدی رو لاگین می کنه الان برای این چطوری یه 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 & "À€244À€1À€6À€" & YCookie & " " & TCookie & "À€98À€usÀ€", 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 & "À€6À€abcdeÀ€98À€usÀ€135À€9.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

----------


## _behnam_

سورس رو به صورت *کامل* قرار بدید نه کد!!!
*واسه من که لاگین نمیشه*

----------


## movaffag

چرا درست کار میکنه من کد گذاشتم معاومه که همه چیز

----------


## _behnam_

> چرا درست کار میکنه من کد گذاشتم معاومه که همه چیز


اینجوری امتحان کردم *لاگین* نشد،
توش موندم چطور میگید *میشه*؟
اگه سورسی که دارید لاگین میشه بزارید تا بررسی شه در صورت *درست* بودن پکت رو *اسنیف* میکنم و میزارم تو سورس

----------


## mafia5000

> چرا از YMSGMod.OCX استفاده نمیکنی؟
> راحتره
> با YMSGMod.OCX :
> Call YMSG1.PckSendMsg(send2.Text, SendPM.Text)


این کامپوننت برای من درست کار نمیکنه وقته برناممو ران میکنم دیگه نمی تونم استاپش کنم فقط میتونم پاوزش کنم

----------


## m2011kh

لاگین میشه ولی نمیدونم چرا تو ساعت ها شلوغ روز مثل بعد از ظهر ها بسته هست و لاگین نمیشه.
صبح زود یا شب دیر وقت متحان کن جواب میده.

----------


## m2011kh

چیزی برای دریافت وجود نداره؟

----------


## m2011kh

همه اینا که میگن برا ارساله چیزی برا دریافت نیست؟

----------


## _behnam_

یعنی چی چیزی واسه* دریافت* نیست؟

----------


## mafia5000

اگر هدر رو عوض کنین مشکل همه پروتکل ها حل میشه

----------

