vb教程:用VB实现一个简单的ESMTP客户端-vb教程

现JMail居然没有for VB例子本来想用C#写个可是家里电脑只有个VB好员是不能受制于开发工具(虽然我并不是个员)

花了个晚上面对着RFC0821和Ethereal截包结果功夫不负有心人终于有个简单例子可以和大家共享了希望大家讨论下(格式不如何好许多异常也没处理另外VB语法已经忘得差不多了请大家谅解！)

项目包括两个文件

1 .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.do.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 sTotal 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\"
state = 3
Case 535 ´incorrect
Quit
state =7
Case Else
End Select
Case 3 ´FROM
Select Case msgType


Case 250
SetRcpt\"\"
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 + \";char=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

延伸阅读

• 2009-1-15-- vb程序设计:VB多媒体程序设计
• 2009-1-15-- vb程序设计:VB程序设计1000问( 2)
• 2009-2-12-- vbpaintpicture:在VB中用Paintpicture方法进行图形处理-vb教程
• 2009-2-12-- microsoftvb:Microsoft .NET 中的基类继承-vb教程
• 2009-2-12-- vb教程:VB初步掌握教程之三
• 2008-9-25-- vb教程:将About加入窗口的系统菜单-vb教程
• 2009-2-12-- vb教程:得到MP3中隐藏的信息-vb教程
• 2008-9-25-- 如何学好vb:如何学好VB-vb教程
• 2009-2-12-- vb教程:贪食蛇-vb教程
• 2008-9-25-- vb教程:怎样在VB中设计背景动画图案-vb教程