★★ 高分相赠：求MIME编码和解码的VB示例。

Question

把包含图片内容HTML内容编码为Base64的MIME，并且可插入附件。越详细越好

Answer 1

看看Option Explicit
Public ServerIp As String 'SMTP服务器地址
Public ServerPort As Long 'SMTP服务器端口Dim strSendName As String '发送人姓名
Dim strReceiveName As String '接收人姓名
Dim strFromMail As String '发送人地址
Dim strToMail As String '接收人地址
Dim m_Date As String '发送日期
Dim strSubject As String '主题
Dim strContent As String '正文
Dim Information As String '从服务器接收响应消息Private Sub cmdAtt_Click()
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
    frmAtt.LstAtt.AddItem cobAtt.List(i)
Next i
cobAtt.Clear
frmAtt.Show vbModal
End SubPrivate Sub cmdSend_Click()
If cobAtt.ListCount > 0 Then
    GenMail True
Else
    GenMail False
End If
'设置Winsock
Wsock.Close
Wsock.RemoteHost = ServerIp
Wsock.RemotePort = ServerPort
'连接SMTP服务器
Wsock.Connect
If Not WaitForResponse("220", 10) Then
    txtMsg.Text = "邮件服务器连接不上......"
    Exit Sub
End If
'打开对话
Wsock.SendData "HELO" & " " & Wsock.LocalHostName & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法打开邮件发送对话" & vbCrLf
    Exit Sub
End If
'发送发送方地址
Wsock.SendData "MAIL FROM:" & " " & strFromMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送发送方地址" & vbCrLf
    Exit Sub
End If
'发送接收方地址
Wsock.SendData "RCPT TO:" & " " & strToMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送接收方地址" & vbCrLf
    Exit Sub
End If
'发送消息体
Wsock.SendData "DATA" & vbCrLf
If Not WaitForResponse("354", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送消息体" & vbCrLf
    Exit Sub
  
End If
Dim fnum As Integer
fnum = FreeFile
Open App.Path & "\mail.tmp" For Input As #fnum
'Wsock.SendData mData & vbCrLf
While Not EOF(fnum)
    Line Input #fnum, strContent
    Wsock.SendData strContent & vbCrLf
Wend
Close #fnum
Wsock.SendData "." & vbCrLf
If Not WaitForResponse("250", 20) Then
    txtMsg.Text = txtMsg.Text & "消息体发送不成功" & vbCrLf
    Exit Sub
End If
'结束邮件发送对话
Wsock.SendData "QUIT" & vbCrLf
If Not WaitForResponse("221", 10) Then
    Exit Sub
End If
Wsock.Close
txtMsg.Text = txtMsg.Text & "邮件发送成功"
End Sub'该按扭事件过程用于设置smtp服务器
Private Sub cmdSetUp_Click()
frmSetup.Show
End Sub'程序加载时读出上次的设置
Private Sub Form_Load()
ServerIp = GetSetting("email", "smtpserver", "serverip", "")
ServerPort = GetSetting("email", "smtpserver", "serverport", 25)
Wsock.Protocol = sckTCPProtocol
End Sub'程序退出时保存设置
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SaveSetting "email", "smtpserver", "serverip", ServerIp
SaveSetting "email", "smtpserver", "serverport", ServerPort
End Sub'接收服务器的响应消息
Private Sub Wsock_DataArrival(ByVal bytesTotal As Long)
Wsock.GetData Information
txtMsg.Text = txtMsg.Text & Information & vbCrLf
End Sub'该函数用于等待服务器响应码
Private Function WaitForResponse(strResponse As String, WaitTime As Integer) As Boolean
Dim WaitSt As Date
WaitSt = Now()
While InStr(1, Information, strResponse, vbTextCompare) < 1
    DoEvents
    If DateDiff("s", WaitSt, Now) > WaitTime Then
       Information = ""
       WaitForResponse = False
       Exit Function
    End If
Wend
Information = ""
WaitForResponse = True
End Function'该函数用于构造信件内容
Private Sub GenMail(bAttachment As Boolean)
Dim fnum As Integer, FAttin As Integer
Dim strLine As String
strSendName = txtSName.Text
strReceiveName = txtRName.Text
strFromMail = txtFrom.Text
strToMail = txtTo.Text
m_Date = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
strSubject = txtSubject.Text
strContent = txtContent.Text
fnum = FreeFile()
Open App.Path & "\mail.tmp" For Output As fnum
'构造信件标题字段
Print #fnum, "From:" & Chr(32) & strSendName
Print #fnum, "Date:" & Chr(32) & m_Date
Print #fnum, "X-Mailer: BigAnt Smtp Mailer V1.0"
Print #fnum, "To:" & Chr(32) & strReceiveName
Print #fnum, "Subject:" & Chr(32) & strSubject
If bAttachment = False Then
    Print #fnum, ""
    Print #fnum, strContent
    Exit Sub
End If
Print #fnum, "MIME-Version: 1.0"
Print #fnum, "Content-type:multipart/mixed;"
Print #fnum, " boundary =""----=_NextPart_000_000A_01BF9F1A"""
Print #fnum, ""
'书写信件的正文内容
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
Print #fnum, "Content-Type: text/plain;"
Print #fnum, "    Charset = ""gb2312"""
Print #fnum, "Content-Transfer-Encoding: 8bit"
Print #fnum, ""
Print #fnum, strContent
'附件内容
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
    Base64Encode cobAtt.List(i), App.Path & "\attachment" & i & ".tmp"
    Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
    Print #fnum, "Content-Type: Application/octet-stream"
    Print #fnum, "  name=" & cobAtt.List(i)
    Print #fnum, "Content-Transfer-Encoding: base64"
    Print #fnum, "Content-Disposition: attachment;"
    Print #fnum, "  FileName=" & cobAtt.List(i)
    Print #fnum, ""
    FAttin = FreeFile
    Open App.Path & "\attachment" & i & ".tmp" For Input As #FAttin
    While Not EOF(FAttin)
        Line Input #FAttin, strLine
        Print #fnum, strLine
    Wend
    Close FAttin
Next i
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A" & "--"
Close fnum
End Sub

Answer 2

Option ExplicitPublic Function Base64Encode(Infile As String, Outfile As String)
Dim FnumIn As Integer, FnumOut As Integer
Dim mInByte(3) As Byte, mOutByte(4) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
FnumIn = FreeFile()
Open Infile For Binary As #FnumIn
FnumOut = FreeFile()
Open Outfile For Binary As #FnumOut
While Not EOF(FnumIn)
    i = 0
    Do While i < 3
    Get #FnumIn, , myByte
    If Not EOF(FnumIn) Then
        mInByte(i) = myByte
        i = i + 1
    Else
        Exit Do
    End If
    Loop
    Base64EncodeByte mInByte, mOutByte, i
    For j = 0 To 3
        Put #FnumOut, , mOutByte(j)
    Next j
    LineLen = LineLen + 1
    If LineLen * 4 > 70 Then
        Put #FnumOut, , vbCrLf
        LineLen = 0
    End If
Wend
Close (FnumOut)
Close (FnumIn)
End FunctionPrivate Sub Base64EncodeByte(mInByte() As Byte, mOutByte() As Byte, Num As Integer)
Dim tByte As Byte
Dim i As IntegerIf Num = 1 Then
    mInByte(1) = 0
    mInByte(2) = 0
ElseIf Num = 2 Then
    mInByte(2) = 0
End IftByte = mInByte(0) And &HFC
mOutByte(0) = tByte / 4
tByte = ((mInByte(0) And &H3) * 16) + (mInByte(1) And &HF0) / 16
mOutByte(1) = tByte
tByte = ((mInByte(1) And &HF) * 4) + ((mInByte(2) And &HC0) / 64)
mOutByte(2) = tByte
tByte = (mInByte(2) And &H3F)
mOutByte(3) = tByteFor i = 0 To 3
    If mOutByte(i) >= 0 And mOutByte(i) <= 25 Then
        mOutByte(i) = mOutByte(i) + Asc("A")
    ElseIf mOutByte(i) >= 26 And mOutByte(i) <= 51 Then
        mOutByte(i) = mOutByte(i) - 26 + Asc("a")
    ElseIf mOutByte(i) >= 52 And mOutByte(i) <= 61 Then
        mOutByte(i) = mOutByte(i) - 52 + Asc("0")
    ElseIf mOutByte(i) = 62 Then
        mOutByte(i) = Asc("+")
    Else
        mOutByte(i) = Asc("/")
    
    End If
Next iIf Num = 1 Then
    mOutByte(2) = Asc("=")
    mOutByte(3) = Asc("=")
ElseIf Num = 2 Then
    mOutByte(3) = Asc("=")
End If
End Sub
Public Function Base64Decode(Infile As String, Outfile As String)
Dim FnumIn As Integer, FnumOut As Integer
Dim mInByte(4) As Byte, mOutByte(3) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
Dim ByteNum As Integer
FnumIn = FreeFile()
Open Infile For Binary As #FnumIn
FnumOut = FreeFile()
Open Outfile For Binary As #FnumOutWhile Not EOF(FnumIn)
    i = 0
    Do While i < 4
    Get #FnumIn, , myByte
    If Not EOF(FnumIn) Then
        If myByte <> &HA And myByte <> &HD Then
        '把回车符和换行符去掉
            mInByte(i) = myByte
            i = i + 1
        End If
    Else
        Exit Do
    End If
    Loop
    Base64DecodeByte mInByte, mOutByte, ByteNum
    
    For j = 0 To 2 - ByteNum
        Put #FnumOut, , mOutByte(j)
    Next j
    'LineLen = LineLen + 1
Wend
Close (FnumOut)
Close (FnumIn)
End FunctionPrivate Sub Base64DecodeByte(mInByte() As Byte, mOutByte() As Byte, ByteNum As Integer)
Dim tByte As Byte
Dim i As Integer
ByteNum = 0
For i = 0 To 3
    If mInByte(i) >= Asc("A") And mInByte(i) <= Asc("Z") Then
        mInByte(i) = mInByte(i) - Asc("A")
    ElseIf mInByte(i) >= Asc("a") And mInByte(i) <= Asc("z") Then
        mInByte(i) = mInByte(i) - Asc("a") + 26
    ElseIf mInByte(i) >= Asc("0") And mInByte(i) <= Asc("9") Then
        mInByte(i) = mInByte(i) - Asc("0") + 52
    ElseIf mInByte(i) = Asc("+") Then
        mInByte(i) = 62
    ElseIf mInByte(i) = Asc("/") Then
        mInByte(i) = 63
    Else '"="
        ByteNum = ByteNum + 1
        mInByte(i) = 0
    End If
Next i
'取前六位
tByte = (mInByte(0) And &H3F) * 4 + (mInByte(1) And &H30) / 16
'0的六位和1的前两位
mOutByte(0) = tByte
tByte = (mInByte(1) And &HF) * 16 + (mInByte(2) And &H3C) / 4
'1的后四位和2的前四位
mOutByte(1) = tByte
tByte = (mInByte(2) And &H3) * 64 + (mInByte(3) And &H3F)
mOutByte(2) = tByte
'2的后两位和3的六位
End Sub

Answer 3

谢谢龙卷风！！可是对于包含图片内容的HTML该怎么办？我试过上面的代码，内容只能是文本，即使是HTML也当做文本显示出来了。

Answer 4

我知道HTML了，需要改动一下。另外，怎样对MIME进行解码？

Answer 5

您想得到好，告诉您，完全想正确进行编码和解码的话，需要很复杂的代码！我到目前为止，还不敢保证我的软件能够不显示出乱码出来！
its screenshot url: 
>http://free.efile.com.cn/huangtao/ScreenShot.jpg 
>
>setup download url: 
>http://free.efile.com.cn/huangtao/SmartmailSource.rar 

Answer 6

有没有mime的编码和解码的组件？
vb写出来的太慢了，尤其是base64那部分。