最近发现JMail居然没有for VB的例子，本来想用C#写一个的，可是家里的电脑只有一个VB，好的程序员是不能受制于开发工具的（虽然我并不是个程序员）。
花了一个晚上，面对着RFC0821和Ethereal的截包结果，功夫不负有心人，终于有一个简单的例子可以和大家共享了，希望大家讨论一下。(格式不怎么好，许多异常也没处理，另外VB的语法已经忘得差不多了，请大家谅解！)
项目包括两个文件
1 main.frm
VERSION 5.00Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"Begin VB.Form Form1 Caption = "Form1" ClientHeight = 4725 ClientLeft = 60 ClientTop = 345 ClientWidth = 5550 LinkTopic = "Form1" ScaleHeight = 4725 ScaleWidth = 5550 StartUpPosition = 3 'Windows Default Begin MSWinsockLib.Winsock smtpClient Left = 1680 Top = 120 _ExtentX = 741 _ExtentY = 741 _Version = 393216 RemoteHost = "mail.domain.com" RemotePort = 25 End Begin VB.CommandButton Command2 Caption = "Connect" Height = 495 Left = 120 TabIndex = 3 Top = 120 Width = 1215 End Begin VB.CommandButton Command1 Caption = "Send" Height = 375 Left = 4560 TabIndex = 2 Top = 4200 Width = 855 End Begin VB.TextBox Text2 Height = 315 Left = 120 TabIndex = 1 Top = 4200 Width = 4215 End Begin VB.TextBox Text1 Height = 3255 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 0 Top = 840 Width = 5295 EndEndAttribute VB_Name = "Form1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalsePrivate state As IntegerPrivate FLAG_LINE_END As StringPrivate FLAG_MAIL_END As String
Private Sub Command1_Click() Text2.Text = base64encode(utf16to8(Text2.Text)) 'Text2.Text = base64decode(utf8to16(Text2.Text))End Sub
Private Sub Command2_Click() state = 0 smtpClient.Close smtpClient.ConnectEnd Sub
Private Sub Form_Load() mailcount = 2 FLAG_LINE_END = Chr(13) + Chr(10) FLAG_MAIL_END = FLAG_LINE_END + "." + FLAG_LINE_ENDEnd Sub
Private Sub Form_Terminate() smtpClient.CloseEnd Sub
Private Sub smtpClient_Close() 'MsgBox "closed!" state = 0End Sub
Private Sub smtpClient_DataArrival(ByVal bytesTotal As Long) Dim s As String smtpClient.GetData s Text1.Text = Text1.Text + s + FLAG_LINE_END Dim msgHead As String msgHead = Left(s, 3) Dim msgBody As String msgBody = Mid(s, 5) Dim msgType As Integer msgType = CInt(msgHead) Dim msgsend As String Select Case state Case 0 'start state Select Case msgType Case 220 msgsend = "EHLO yourname" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_END state = 1 Case 421 'Service not available End Select Case 1 'EHLO Select Case msgType Case 250 msgsend = "AUTH LOGIN" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_END state = 2 Case 500, 501, 504, 421 'error happened End Select Case 2 'AUTH LOGIN Select Case msgType Case 334 If msgBody = "VXNlcm5hbWU6" + FLAG_LINE_END Then msgsend = base64encode(utf16to8("username")) + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_END ElseIf msgBody = "UGFzc3dvcmQ6" + FLAG_LINE_END Then msgsend = base64encode(utf16to8("password")) + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_END End If Case 235 'correct SetFrom "you@domain.com" state = 3 Case 535 'incorrect Quit state = 7 Case Else End Select Case 3 'FROM Select Case msgType Case 250 SetRcpt "rpct@domain.com" state = 4 Case 221 Quit state = 7 Case 573 Quit state = 7 Case 552, 451, 452 'failed Case 500, 501, 421 'error End Select Case 4 'RCPT Select Case msgType Case 250, 251 'user is ok msgsend = "DATA" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_END state = 5 Case 550, 551, 552, 553, 450, 451, 452 'failed Quit state = 7
Case 500, 501, 503, 421 'error Quit state = 7 End Select Case 5 'DATA been sent Select Case msgType Case 354 Send "from", "to", "no subject", "plain", "test" Text1.Text = Text1.Text + msgsend + FLAG_LINE_END state = 6 Case 451, 554 Case 500, 501, 503, 421 End Select Case 6 'body been sent Select Case msgType Case 250 Quit state = 7 Case 552, 451, 452 Case 500, 501, 502, 421 End Select Case 7 Select Case msgType Case 221 'process disconnected state = 0 Case 500 'command error End Select End Select End Sub
Private Sub Quit() Dim msgsend As String rs.Close conn.Close msgsend = "QUIT" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_ENDEnd Sub
Private Sub Send(from As String, to1 As String, subject As String, ctype As String, content As String) Dim msgsend As String msgsend = "From: " + from + FLAG_LINE_END msgsend = msgsend + "To: " + to1 + FLAG_LINE_END msgsend = msgsend + "Subject: " + subject + FLAG_LINE_END msgsend = msgsend + "Date: " + CStr(Now) + FLAG_LINE_END msgsend = msgsend + "MIME-Version: 1.0" + FLAG_LINE_END msgsend = msgsend + "Content-Type: text/" + ctype + ";charset=gb2312" + FLAG_LINE_END 'msgSend = msgSend + "Content-Transfer-Encoding: base64" + flag_line_end msgsend = msgsend + content + FLAG_LINE_END smtpClient.SendData msgsend smtpClient.SendData FLAG_MAIL_ENDEnd SubPrivate Sub SetFrom(from As String) msgsend = "MAIL FROM: <" + from + ">" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_ENDEnd SubPrivate Sub SetRcpt(rcpt As String) Dim msgsend As String msgsend = "RCPT TO: <" + rcpt + ">" + FLAG_LINE_END smtpClient.SendData msgsend Text1.Text = Text1.Text + msgsend + FLAG_LINE_ENDEnd Sub
Private Sub smtpClient_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) MsgBox DescriptionEnd Sub
2 func.bas
Attribute VB_Name = "Module1"Private base64EncodeChars As StringPrivate base64DecodeChars(127) As Integer
Function base64encode(str As String) As String base64EncodeChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim out, i, len1 Dim c1, c2, c3 len1 = Len(str) i = 0 out = "" While i < len1 c1 = Asc(Mid(str, i + 1, 1)) i = i + 1 If (i = len1) Then out = out + Mid(base64EncodeChars, c1 / 4 + 1, 1) out = out + Mid(base64EncodeChars, (c1 And 3) * 16 + 1, 1) out = out + "==" base64encode = out Exit Function End If c2 = Asc(Mid(str, i + 1, 1)) i = i + 1 If (i = len1) Then out = out + Mid(base64EncodeChars, c1 / 4 + 1, 1) out = out + Mid(base64EncodeChars, (((c1 And 3) * 16) Or ((c2 And 240) / 16)) + 1, 1) out = out + Mid(base64EncodeChars, (c2 And 15) * 4 + 1, 1) out = out + "=" base64encode = out Exit Function End If c3 = Asc(Mid(str, i + 1, 1)) i = i + 1 out = out + Mid(base64EncodeChars, c1 / 4 + 1, 1) out = out + Mid(base64EncodeChars, (((c1 And 3) * 16) Or ((c2 And 240) / 16)) + 1, 1) out = out + Mid(base64EncodeChars, (((c2 And 15) * 4) Or ((c3 And 192) / 64)) + 1, 1) out = out + Mid(base64EncodeChars, (c3 And 63) + 1, 1) Wend
base64encode = outEnd Function
Function base64decode(str As String) As String
For i = 0 To 127 base64DecodeChars(i) = -1 Next base64DecodeChars(43) = 62 base64DecodeChars(47) = 63
For i = 48 To 57 base64DecodeChars(i) = i + 4 Next
For i = 65 To 90 base64DecodeChars(i) = i - 65 Next
For i = 97 To 122 base64DecodeChars(i) = i - 71 Next
Dim c1, c2, c3, c4 Dim len1, out
len1 = Len(str) i = 0 out = "" While (i < len1) Do c1 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255) i = i + 1 Loop While (i < len1 And c1 = -1) If (c1 = -1) Then base64decode = out Exit Function End If Do c2 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255) i = i + 1 Loop While (i < len1 And c2 = -1) If (c2 = -1) Then base64decode = out Exit Function End If out = out + Chr((c1 * 4) Or ((c2 And 48) / 16))
Do c3 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255) i = i + 1 If (c3 = 61) Then base64decode = out c3 = base64DecodeChars(c3) End If Loop While (i < len1 And c3 = -1) If (c3 = -1) Then base64decode = out Exit Function End If out = out + Chr(((c2 And 15) * 16) Or ((c3 And 60) / 4))
Do c4 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255) i = i + 1 If (c4 = 61) Then base64decode = out c4 = base64DecodeChars(c4) End If Loop While (i < len1 And c4 = -1) If (c4 = -1) Then base64decode = out Exit Function End If
out = out + Chr(((c3 And 3) * 64) Or c4) Wend base64decode = outEnd Function
Function utf16to8(str As String) As String
Dim out, i, len1, c out = "" len1 = Len(str) For i = 1 To len1 c = Asc(Mid(str, i, 1)) If ((c >= 1) And (c <= 127)) Then out = out + Mid(str, i, 1) ElseIf (c > 2047) Then out = out + Chr(224 Or ((c / 4096) And 15)) out = out + Chr(128 Or ((c / 64) And 63)) out = out + Chr(128 Or (c And 63)) Else out = out + Chr(192 Or ((c / 64) And 31)) out = out + Chr(128 Or (c And 63)) End If Next utf16to8 = outEnd Function
Function utf8to16(str As String) As String
Dim out, i, len1, c Dim char2, char3
out = "" len1 = Len(str) i = 0 While (i < len1) c = Asc(Mid(str, i + 1, 1)) i = i + 1 Select Case (c / 16) Case 0 To 7 out = out + Mid(str, i, 1) Case 12, 13 char2 = Asc(Mid(str, i + 1, 1)) i = i + 1 out = out + Chr(((c And 31) * 64) Or (char2 And 31)) Case 14 char2 = Asc(Mid(str, i + 1, 1)) i = i + 1 char3 = Asc(Mid(str, i + 1, 1)) i = i + 1 out = out + Chr(((c And 15) * 4096) Or ((char2 And 63) * 64) Or ((char3 And 63))) End Select Wend
utf8to16 = outEnd Function
