项目包括两个文件

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