|
|
 |
| Beginning VB 6 For coders who are new to Visual Basic, working in VB version 6 (not .NET). |
Welcome to the p2p.wrox.com Forums.
You are currently viewing the Beginning VB 6 section of the Wrox p2p Programmer to Programmer discussion community. This is a community of more than 40,000 computer programmers including Wrox book authors and readers. As a guest, you can read any forum posting. By joining our free Wrox p2p community you can post your own programming questions and respond to other programmers’ questions. Registered users also don't have to see the ads that are displayed to guests. Registration is fast, simple and absolutely free so please, join today!
Join today and post to win prizes! Post more to increase your chances of being Wrox’s top poster of the month.
|
 |
December 19th, 2006, 03:10 AM
|
|
Registered User
|
|
Join Date: Dec 2006
Location: padova, italy, Italy.
Posts: 2
Thanks: 0
Thanked 0 Times in 0 Posts
|
|
msn help
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
__________________
 my AES SIGNATURE .....5C9BE915002494714BC908F9105FE3EDC163793ADD397 2C791E6695BDB79D556
|
December 19th, 2006, 02:44 PM
|
|
Friend of Wrox
|
|
Join Date: Jun 2003
Location: Alameda, ca, USA.
Posts: 627
Thanks: 0
Thanked 0 Times in 0 Posts
|
|
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
|
December 21st, 2006, 02:51 PM
|
|
Registered User
|
|
Join Date: Dec 2006
Location: padova, italy, Italy.
Posts: 2
Thanks: 0
Thanked 0 Times in 0 Posts
|
|
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() & " msmsgs@msnmsgr.com 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
|
| Thread Tools |
Search this Thread |
|
|
|
| Display Modes |
 Linear Mode
|
Posting Rules
|
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts
HTML code is Off
|
|
|
|
|
