msn help

muteblaster · December 19th, 2006, 03:10 AM

hallo at olways.....

this is my first message in this forum

......

i am workin in a msn clone in vb6.....this program is no install and very light..........
but in my work i have found same problem on smile......the smile is realy simple but for same reason when i send a message whith smile the program ghive me an error......

you found my work at p2pforum http://www.p2pforum.it/forum/showthread.php?t=105677

if you wont to help reply here.......or if you areinterested in developped woch the source and ghive me my opinion......

bye......

 my AES SIGNATURE .....5C9BE915002494714BC908F9105FE3EDC163793ADD397 2C791E6695BDB79D556

marcostraf · December 19th, 2006, 02:44 PM

ciao muteblaster, small world indeed...

what do you mean with "smile"? the little smiling faces like this :) ?
are you sure that you are not sending a picture instead of an ascii smile? can you post a snippet of your code?

see you around
Marco

"There are two ways to write error-free programs. Only the third one works."
Unknown

muteblaster · December 21st, 2006, 02:51 PM

hallo marco the world is very litle :)

the smile code is not difficult but the problem is not the smile is when i send it the program crashed.....

this is the code in the formmessage

Code:

Option Explicit

Public SessionID As String
Public AuthString As String
Public RemoteHost As String
Public RemotePort As Integer
Public ContactName As String
Public ContactEmail As String
Public WindowID As Integer

Public Participants As Boolean

Dim messa As Integer

Dim trID_b As Integer

Function trID()
    trID_b = trID_b + 1
    trID = trID_b
End Function

Private Sub btn_smiley_Click()
End Sub

Private Sub cmdSend_Click()
    testocript = Encode(txtMessage.Text)
    If Ck_Cript.Value = 0 Then
       Passa_Stato_Cript = False
    Else
       Passa_Stato_Cript = True
    End If
    If Participants = True Then
       If Ck_Cript.Value = 0 Then
          sendMessage txtMessage, Me.WindowID
       Else
          sendMessage testocript, Me.WindowID
       End If
    Else
        messa = messa + 1
        ReDim Preserve savedMessages(messa)
        If Ck_Cript.Value = 0 Then
           savedMessages(messa) = Me.WindowID & ":/:/:::r0binrules://" & txtMessage.Text
        Else
           savedMessages(messa) = Me.WindowID & ":/:/:::r0binrules://" & testocript
        End If
        Send "CAL " & trID() & " " & ContactEmail
    End If
    txtMessage = ""
End Sub

Private Sub Command1_Click()
    Frame1.Visible = Not Frame1.Visible
End Sub



Private Sub Command2_Click()
Form_sicurezza.Show
End Sub






Private Sub Commandhotmail_Click()
Shell "explorer http://www.hotmail.com"
End Sub

Private Sub Form_Load()
    Ck_Cript.Value = 0
    Dim a As Integer
    For a = 1 To frmMessage.smylist.ListImages.Count
        smyl(a - 1) = frmMessage.smylist.ListImages(a).Picture
        DoEvents
    Next
    Connect
End Sub

Public Sub Connect()
    trID_b = -1
    sckMessage.Close
    sckMessage.Connect RemoteHost, RemotePort
    Me.Caption = ContactName & " (" & ContactEmail & ")"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Send "OUT"
End Sub

Private Sub rtfLog_Change()
    'txtMessage.SetFocus
    tmTyping.Enabled = True
    sbPanel.Panels(1).Text = "Nuovo Messaggio ricevuto alle " & Time & ", " & Date
End Sub


Private Sub sckMessage_Connect()
    If Not SessionID = -1 Then
        Send "ANS " & trID() & " " & frmMain.txtUsername & " " & AuthString & " " & SessionID
        rtfLog.SelStart = Len(rtfLog.Text)
        rtfLog.SelIndent = 0
        rtfLog.SelText = ContactName & " (" & ContactEmail & ") has joined the conversation" & vbCrLf
        Participants = True
    Else
        Send "USR " & trID() & " " & frmMain.txtUsername & " " & AuthString
    End If
End Sub

Private Sub sckMessage_DataArrival(ByVal bytesTotal As Long)

    Dim gotString As String
    sckMessage.GetData gotString
    CParse gotString, Me.WindowID

End Sub

Private Sub sckMessage_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)
    rtfLog.SelStart = Len(rtfLog.Text)
    rtfLog.SelIndent = 0
    rtfLog.SelText = "Error: " & Description & vbCrLf & " please reopen the message box and try again" & vbCrLf
End Sub

Sub Send(Str)
    Log "Out: " & Str
    If sckMessage.State = sckConnected Then
        sckMessage.SendData Str & vbCrLf
    End If
End Sub


Private Sub smyl_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
If smyl(Index).Picture <> 0 Then
    Shape3.Left = smyl(Index).Left
    Shape3.Top = smyl(Index).Top
End If
End Sub


Private Sub tmTyping_Timer()
    sbPanel.Panels(1).Text = Urldecode(Me.ContactName) & " has stopped typing."
    tmTyping.Enabled = True
End Sub

Private Sub txtMessage_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        cmdSend.SetFocus
        cmdSend_Click
        txtMessage.SetFocus
        txtMessage = ""
        SendKeys "{backspace}"
    End If
End Sub

and this is the module in reletid ito the send

Code:

Option Explicit

Public budCount As Integer
Public MessageWindows As Integer

Public nForm() As frmMessage
Private nMessage As RecieveMessage

Public savedMessages() As String

Private ParsingMessage As Boolean

Public FoundForm As Integer

Sub sendMessage(message As String, Window As Integer)
    ' >>> MSG 4 U 91\r\n
    'MIME-Version: 1.0\r\n
    'Content-Type: text/x-msmsgscontrol\r\n
    'TypingUser:     alice@ passport.com \ r \ n

    '>>> MSG 5 N 138\r\n
    'MIME-Version: 1.0\r\n
    'Content-Type: text/plain; charset=UTF-8\r\n
    'X-MMS-IM-Format: FN=MS%20Sans%20Serif; EF=; CO=0; CS=0; PF=0\r\n
    '\r\n
    'Are you there?

    Dim bMess As String
    bMess = _
    "MIME-Version: 1.0" & vbCrLf & _
    "Content-Type: text/plain; charset=UTF-8" & vbCrLf & _
    "X-MMS-IM-Format: FN=MS%20Sans%20Serif; EF=; CO=0; CS=0; PF=0" & vbCrLf & _
    "" & vbCrLf & _
    message

    If Len(message) > 0 Then
        nForm(Window).sckMessage.SendData "MSG " & nForm(Window).trID() & " U " & Len(bMess) & vbCrLf & bMess

        nForm(Window).rtfLog.Locked = False
        nForm(Window).rtfLog.SelStart = Len(nForm(Window).rtfLog.Text)
        nForm(Window).rtfLog.SelIndent = 0
        nForm(Window).rtfLog.SelText = frmMain.lblName & " dice alle " & Time & ":" & vbCrLf
        'nForm(Window).rtfLog.SelFontName = FontName
        'nForm(Window).rtfLog.SelBold = FontBold
        'nForm(Window).rtfLog.SelItalic = FontItalic
        'nForm(Window).rtfLog.SelStrikeThru = FontStrikethru
        'nForm(Window).rtfLog.SelUnderline = FontUnderline
        'nForm(Window).rtfLog.SelColor = FontColor
        nForm(Window).rtfLog.SelIndent = 200
        'decripta messaggio inizio modificA by muteblaster con algoritmopersonale
        testodecript = DeCode(message)
        If Passa_Stato_Cript = False Then
           nForm(Window).rtfLog.SelText = message & vbCrLf ' riga originale
        Else
           nForm(Window).rtfLog.SelText = testodecript & vbCrLf ' vien messo a video il testo decifrato
        End If
        'fine modifica
        nForm(Window).rtfLog.Locked = True
    End If

End Sub

Sub ParseMessage(message As RecieveMessage, Window As Integer)

    Dim prsLines() As String
    Dim prsLine
    Dim prsVar() As String
    Dim prsMnr() As String
    Dim prsMnra
    Dim prsVart() As String

    Dim FontName As String
    Dim FontColor As Long
    Dim FontBold As Boolean
    Dim FontItalic As Boolean
    Dim FontStrikethru As Boolean
    Dim FontUnderline As Boolean

    Dim MessageBegins As Boolean

    prsLines = Split(message.Content, vbCrLf)

    For Each prsLine In prsLines
        If Len(prsLine) > 0 Then

            If MessageBegins = True Then
                message.Content = message.Content & prsLine
            End If

            prsVar = Split(CStr(prsLine), ": ")
            If prsVar(0) = "TypingUser" Then
                message.Content = ""
                nForm(Window).sbPanel.Panels(1).Text = prsVar(1) & " is typing a message..."
                nForm(Window).tmTyping.Enabled = True
            End If
            If prsVar(0) = "X-MMS-IM-Format" Then
                prsMnr = Split(prsVar(1), "; ")
                Log prsVar(1)
                For Each prsMnra In prsMnr
                    prsVart = Split(CStr(prsMnra), "=")

                    If prsVart(0) = "FN" Then
                        FontName = Urldecode(prsVart(1))
                    End If
                    If prsVart(0) = "EF" Then
                        If InStr(prsVart(1), "B") Then FontBold = True
                        If InStr(prsVart(1), "I") Then FontItalic = True
                        If InStr(prsVart(1), "S") Then FontStrikethru = True
                        If InStr(prsVart(1), "U") Then FontUnderline = True
                    End If
                    If prsVart(0) = "CO" Then
                        FontColor = HexToDecColor(StrReverse(prsVart(1)))
                    End If
                Next

                MessageBegins = True
                message.Content = ""
            End If

        End If
    Next

    If Len(nMessage.Content) > 0 Then
        nForm(Window).rtfLog.Locked = False
        nForm(Window).rtfLog.SelStart = Len(nForm(Window).rtfLog.Text)
        nForm(Window).rtfLog.SelIndent = 0
        nForm(Window).rtfLog.SelText = message.ContactName & " says at " & Time & ":" & vbCrLf
        nForm(Window).rtfLog.SelFontName = FontName
        nForm(Window).rtfLog.SelBold = FontBold
        nForm(Window).rtfLog.SelItalic = FontItalic
        nForm(Window).rtfLog.SelStrikeThru = FontStrikethru
        nForm(Window).rtfLog.SelUnderline = FontUnderline
        nForm(Window).rtfLog.SelColor = FontColor
        nForm(Window).rtfLog.SelIndent = 200
        nForm(Window).rtfLog.SelText = message.Content & vbCrLf
        nForm(Window).rtfLog.Locked = True
    End If

End Sub

Sub CParse(Str, Optional Window As Integer)
    On Error GoTo Logit

    Dim prsWords() As String
    prsWords = Split(CStr(Str), " ")

    If prsWords(0) = "MSG" Then
        nMessage.ContactEmail = prsWords(1)
        nMessage.ContactName = Urldecode(prsWords(2))
        nMessage.Length = CInt(Split(prsWords(3), vbCrLf)(0))
        nMessage.Content = Mid(Str, InStr(Str, vbCrLf) + 2, nMessage.Length)

        ParseMessage nMessage, Window
        Exit Sub
    End If

    If prsWords(0) = "USR" Then
        nForm(Window).Send "CAL " & nForm(Window).trID() & " " & nForm(Window).ContactEmail
    End If

    If prsWords(0) = "JOI" Then
        nForm(Window).rtfLog.SelStart = Len(nForm(Window).rtfLog.Text)
        nForm(Window).rtfLog.SelIndent = 0
        nForm(Window).rtfLog.SelText = Urldecode(CStr(Split(prsWords(2), vbCrLf)(0))) & " (" & prsWords(1) & ") has joined the conversation" & vbCrLf
        nForm(Window).Participants = True
        If UBound(savedMessages) > 0 Then
            Dim i As Integer
            Dim message As String
            For i = 0 To UBound(savedMessages)
                message = savedMessages(i)
                If Len(message) > 0 Then
                    If Split(message, ":/:/:::r0binrules://")(0) = Window Then
                        sendMessage CStr(Split(message, ":/:/:::r0binrules://")(1)), Window
                        savedMessages(i) = ""
                    End If
                End If
            Next
        End If
    End If

    If prsWords(0) = "BYE" Then
        nForm(Window).rtfLog.SelStart = Len(nForm(Window).rtfLog.Text)
        nForm(Window).rtfLog.SelIndent = 0
        nForm(Window).rtfLog.SelText = "User has closed the conversation window" & vbCrLf
        nForm(Window).Participants = False
    End If

Logit:
    If Err.Number > 0 Then Log Err.Description
End Sub

Sub Parse(Str)

    On Error GoTo Logit

    Dim prsLines() As String
    Dim prsLine
    prsLines = Split(Str, vbCrLf)

    For Each prsLine In prsLines

        If Len(CStr(prsLine)) > 2 Then

            Dim prsWords() As String
            prsWords = Split(CStr(prsLine), " ")

            If message.Recieving = True Then
                message.Content = message.Content & CStr(prsLine) & vbCrLf
                message.Length = message.Length - Len(CStr(prsLine) & vbCrLf)
                If message.Length <= 2 Then
                    Log message.Content

                    Dim controla
                    For Each controla In frmMain.Controls
                        If controla.Tag = "x" Then
                            controla.Enabled = True
                        End If
                    Next

                    Send_Command "SYN " & trID() & " 0"
                    frmMain.Height = 5775

                    message.Recieving = False
                    message.Content = ""
                    message.Length = 0
                End If
            Else
                Log "In:  " & CStr(prsLine)

                If prsWords(0) = "VER" Then
                    Send_Command "CVR " & trID() & " 0x0409 win 4.10 i386 MSNMSGR 7.0.0816 MSMSGS " & frmMain.txtUsername
                End If

                If prsWords(0) = "CVR" Then
                    Send_Command "USR " & trID() & " TWN I " & frmMain.txtUsername
                End If

                If prsWords(0) = "XFR" Then
                    If prsWords(2) = "NS" Then
                        frmMain.sckMain.Close
                        Log "Disconnected"
                        frmMain.sckMain.Connect Split(prsWords(3), ":")(0), Split(prsWords(3), ":")(1)
                    ElseIf prsWords(2) = "SB" Then

                        nForm(FoundForm).SessionID = -1
                        nForm(FoundForm).RemoteHost = Split(prsWords(3), ":")(0)
                        nForm(FoundForm).RemotePort = Split(prsWords(3), ":")(1)
                        nForm(FoundForm).AuthString = prsWords(5)

                        Load nForm(FoundForm)
                        nForm(FoundForm).Show

                    End If
                End If

                If prsWords(0) = "USR" Then

                    If prsWords(2) = "TWN" Then
                        frmMain.inetLogin.Execute nexusURL, "GET", "", _
                        "Authorization: Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & Urlencode(frmMain.txtUsername.Text) & ",pwd=" & frmMain.txtPassword & "," & prsWords(4) & vbCrLf & _
                        "Host: login.passport.com" & vbCrLf
                    End If

                    If prsWords(2) = "OK" Then
                        frmMain.lblName = prsWords(4)
                        Log "Login Success!"
                    End If

                End If

                If prsWords(0) = "MSG" Then

                    If prsWords(1) = "Hotmail" And prsWords(2) = "Hotmail" Then
                        message.Length = prsWords(3)
                        message.Recieving = True
                    End If

                End If

                If prsWords(0) = "SYN" Then
                    List.totalGroups = prsWords(4)
                    List.totalBuddies = prsWords(3)

                    ReDim List.Groups(List.totalGroups)
                    ReDim List.Buddies(List.totalBuddies)
                End If

                If prsWords(0) = "LSG" Then
                    List.Groups(prsWords(1)) = prsWords(2)
                End If

                If prsWords(0) = "LST" Then

                    With List.Buddies(budCount)
                        .Email = prsWords(1)
                        .FriendlyName = Urldecode(prsWords(2))
                        .Status = "FLN"
                        If UBound(prsWords) >= 4 Then
                            .Group = prsWords(4)
                        Else
                            Log Urldecode(prsWords(2)) & " (" & prsWords(1) & ") has added you to their Friends list!"
                            Log "Automatically adding..."

                            Send_Command "ADD " & trID() & " AL " & prsWords(1) & " " & prsWords(1)
                            Send_Command "ADD " & trID() & " FL " & prsWords(1) & " " & prsWords(1)
                        End If
                    End With

                    budCount = budCount + 1

                    If budCount = UBound(List.Buddies) Then
                        Send_Command "CHG " & trID() & " NLN " & 32
                    End If

                End If

                If prsWords(0) = "ILN" Then

                    List.Buddies(GetBuddyByEmail(prsWords(3))).Status = prsWords(2)
                    List.Buddies(GetBuddyByEmail(prsWords(3))).FriendlyName = Urldecode(prsWords(4))
                    UpdateList

                End If

                If prsWords(0) = "CHL" Then
                    Dim ToSend As String

                    ToSend = "QRY " & trID() & " [email protected] 32" & vbCrLf
                    ToSend = ToSend & DigestStrToHexStr(prsWords(2) & "Q1P7W2E4J9R8U3S5")

                    frmMain.sckMain.SendData ToSend
                End If

                If prsWords(0) = "NLN" Then

                    List.Buddies(GetBuddyByEmail(prsWords(2))).Status = prsWords(1)
                    List.Buddies(GetBuddyByEmail(prsWords(2))).FriendlyName = Urldecode(prsWords(3))
                    UpdateList

                End If

                If prsWords(0) = "FLN" Then

                    List.Buddies(GetBuddyByEmail(prsWords(1))).Status = prsWords(0)
                    UpdateList

                End If

                If prsWords(0) = "REM" Then
                    If prsWords(2) = "RL" Then
                        Log prsWords(4) & " has removed you from their buddy list! Removing.."
                        Send_Command "REM " & trID() & " AL " & prsWords(4)
                        Send_Command "REM " & trID() & " FL " & prsWords(4)
                    End If
                End If

                If prsWords(0) = "ADD" Then

                    If prsWords(2) = "RL" Then

                        Log Urldecode(prsWords(5)) & " (" & prsWords(4) & ") has added you to their Friends list!"
                        Log "Automatically adding..."

                        Send_Command "ADD " & trID() & " AL " & prsWords(4) & " " & prsWords(4)
                        Send_Command "ADD " & trID() & " FL " & prsWords(4) & " " & prsWords(4)

                        List.totalBuddies = List.totalBuddies + 1
                        List.Buddies(List.totalBuddies).Email = prsWords(4)
                        List.Buddies(List.totalBuddies).FriendlyName = Urlencode(prsWords(5))
                        List.Buddies(List.totalBuddies).Group = 0

                    End If

                End If

                If prsWords(0) = "RNG" Then
                    Dim i As Integer
                    For i = 1 To MessageWindows
                        If nForm(i).ContactEmail = prsWords(5) Then

                            nForm(i).SessionID = prsWords(1)
                            nForm(i).RemoteHost = Split(prsWords(2), ":")(0)
                            nForm(i).RemotePort = Split(prsWords(2), ":")(1)
                            nForm(i).AuthString = prsWords(4)
                            nForm(i).ContactEmail = prsWords(5)
                            nForm(i).ContactName = Urldecode(prsWords(6))
                            nForm(i).WindowID = MessageWindows

                            Load nForm(MessageWindows)
                            nForm(MessageWindows).Show

                            nForm(MessageWindows).Connect

                            Exit Sub

                        End If
                    Next

                    MessageWindows = MessageWindows + 1
                    ReDim Preserve nForm(MessageWindows)
                    Set nForm(MessageWindows) = New frmMessage

                        nForm(MessageWindows).SessionID = prsWords(1)
                        nForm(MessageWindows).RemoteHost = Split(prsWords(2), ":")(0)
                        nForm(MessageWindows).RemotePort = Split(prsWords(2), ":")(1)
                        nForm(MessageWindows).AuthString = prsWords(4)
                        nForm(MessageWindows).ContactEmail = prsWords(5)
                        nForm(MessageWindows).ContactName = Urldecode(prsWords(6))
                        nForm(MessageWindows).WindowID = MessageWindows

                    Load nForm(MessageWindows)
                    nForm(MessageWindows).Show

                End If

            End If

        End If

    Next

Logit:
    If Err.Number > 0 Then Log Err.Description
End Sub

the complite code is available on p2pforum ....italina file sharing power.....

bye

 my AES SIGNATURE .....5C9BE915002494714BC908F9105FE3EDC163793ADD397 2C791E6695BDB79D556