31.txt

VB文章集（含API、窗口、数据库、多媒体、系统、文件、等等）

发送电子邮件附件



只有在用户选择保存附件的情况下，才需要进行解码工作。此时用户需要先选定要保存的文件，然后按Save As按钮。代码如下：

Private Sub cmdSave_Click()

Dim strFileName As String
Dim strMessage As String
Dim strAttachment As String
Dim lngPosA As Long
Dim lngPosB As Long

'Extract full text of the message
strMessage = m_colMessages(lvMessages.SelectedItem.Key).MessageText
'Extract name of the file
strFileName = lvAttachments.SelectedItem.Key
'
Do Until lngPosA = 0
   'Looking for the file's name in the message's text
   lngPosA = InStr(lngPosA + 1, strMessage, " " & strFileName)
   If lngPosA > 0 Then
      'End of string with the file's name
      lngPosB = InStrRev(strMessage, vbCrLf, lngPosA) + 2
      If lngPosB > 2 Then
         'Check whether the string with the file's name 
         'is the part of the "begin" marker
         If (Mid$(strMessage, lngPosB, lngPosA - lngPosB _
            + Len(strFileName) + 1)) Like _
            ("begin ### " & strFileName) Then
            'Position of the end marker
            lngPosA = InStr(lngPosA, strMessage, "'" & _
                      vbCrLf & "end" & vbCrLf)
            If lngPosA > 0 Then
               With ComDialog
                  'Bring up the file selection dialog
                  .FileName = strFileName
                  .ShowSave
                  If Err = 0 Then
                     'Encoding data save to the strAttachment
                     'variable
                     strAttachment = Mid$(strMessage, lngPosB, _
                                     lngPosA + 8 - lngPosB)
                     'Pass it to the UUDecodeToFile routine
                     'in order to decode and save as file
                     UUDecodeToFile strAttachment, .FileName
                  End If
               End With
            End If
         End If
      End If
   End If
Loop
End Sub

最后是UUDecodeToFile函数的代码： 

Public Function UUDecodeToFile(strUUCodeData As String,  strFilePath As String)

Dim vDataLine   As Variant
Dim vDataLines  As Variant
Dim strDataLine As String
Dim intSymbols  As Integer
Dim intFile     As Integer
Dim strTemp     As String
'
'Remove first marker
If Left$(strUUCodeData, 6) = "begin " Then
   strUUCodeData = Mid$(strUUCodeData,  InStr(1, strUUCodeData, vbLf) + 1)
End If
'
'Remove marker of the attachment's end
If Right$(strUUCodeData, 5) = "end" + vbCrLf Then
   strUUCodeData = Left$(strUUCodeData, Len(strUUCodeData) - 10)
End If
intFile = FreeFile
Open strFilePath For Binary As intFile
'Break decoded data to the strings
'From now each member of the array vDataLines contains
'one line of the encoded data
vDataLines = Split(strUUCodeData, vbCrLf)
For Each vDataLine In vDataLines
   'Decode data line by line
   '
strDataLine = CStr(vDataLine)
   'Extract the number of characters in the string
   'We can figure it out by means of the first string character
intSymbols = Asc(Left$(strDataLine, 1))
   'which we delete because of its uselessness
strDataLine = Mid$(strDataLine, 2, intSymbols)
   'Decode the string by 4 bytes portion. 
   'From each byte remove two oldest bits.
   'From remain 24 bits make 3 bytes
For i = 1 To Len(strDataLine) Step 4
      '1 byte
      strTemp = strTemp + Chr((Asc(Mid(strDataLine, i, 1)) _
                - 32) * 4 + (Asc(Mid(strDataLine, i + 1, 1)) _
                - 32) \ 16)
      '2 byte
      strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 1, 1))_
                Mod 16) * 16 + (Asc(Mid(strDataLine, i + 2, 1))_
                - 32) \ 4)
      '3 byte
      strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 2, 1)) _
                Mod 4) * 64 + Asc(Mid(strDataLine, i + 3, 1)) - 32)
   Next i
   'Write decoded string to the file
   Put intFile, , strTemp
   'Clear the buffer in order to receive the next _
   'line of the encoded data
   strTemp = ""
Next
Close intFile
End Function 
看上去似乎就这么多了。其实不然。要想编写出现代电子邮件程序，你必须了解Base 64和MIME用的Quoted-Printalbe算法。不过你放心，本站介绍的算法大多数的邮件程序还是能识别的。只不过它的年纪比较老，现在的电子邮件程序往往是最后才用这种算法。