用VB实现一个简单的ESMTP客户端
最近发现JMail居然没有for VB的例子，本来想用C#写一个的，可是家里的电脑只有一个VB，好的程序员是不能受制于开发工具的（虽然我并不是个程序员）。
花了一个晚上，面对着RFC0821和Ethereal的截包结果，功夫不负有心人，终于有一个简单的例子可以和大家共享了，希望大家讨论一下。(格式不怎么好，许多异常也没处理，另外VB的语法已经忘得差不多了，请大家谅解！)
项目包括两个文件
1 main.frm
VERSION 5.00
Object = "{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
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private state As Integer
Private FLAG_LINE_END As String
Private 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.Connect
End Sub
Private Sub Form_Load()
mailcount = 2
FLAG_LINE_END = Chr(13) + Chr(10)
FLAG_MAIL_END = FLAG_LINE_END + "." + FLAG_LINE_END
End Sub
Private Sub Form_Terminate()
smtpClient.Close
End Sub
Private Sub smtpClient_Close()
'MsgBox "closed!"
state = 0
End 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_END
End 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_END
End Sub
Private Sub SetFrom(from As String)
msgsend = "MAIL FROM: <" + from + ">" + FLAG_LINE_END
smtpClient.SendData msgsend
Text1.Text = Text1.Text + msgsend + FLAG_LINE_END
End Sub
Private 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_END
End 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 Description
End Sub
2 func.bas
Attribute VB_Name = "Module1"
Private base64EncodeChars As String
Private 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 = out
End 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 = out
End 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 = out
End 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 = out
End Function
