用VB实现一个简单的ESMTP客户端

项目包括两个文件

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