vbmime.cls

简单、实用、特别。 有很多不足之处

    'Only the Mail Headers
    m_strHeaders = Left$(strMessage, intPosA - 1)
    'E-Mail + Attachments
    m_strMessageBody = Right$(strMessage, Len(strMessage) - intPosA - 3)
    'Whole E-Mail (Header + Message + Attachments)
    m_strMessageText = strMessage

    'Hmm I try to unfold the Mail Header...
    m_strHeaders = Replace(m_strHeaders, vbCrLf + Chr$(9), " ")
    m_strHeaders = Replace(m_strHeaders, vbCrLf + Chr$(11), " ")
    m_strHeaders = Replace(m_strHeaders, vbCrLf + Chr$(32), " ")
    m_strHeaders = Replace(m_strHeaders, vbCrLf + Chr$(255), " ")

    'Parse Mail Header and save data
    vHeaders = Split(m_strHeaders, vbCrLf)

    intFrom = LBound(vHeaders)
    intTo = UBound(vHeaders)

    For intTemp = intFrom To intTo
        strHeader = vHeaders(intTemp)
        intPosA = InStr(1, strHeader, ":")
        If intPosA Then
            strHeaderName = LCase$(Left$(strHeader, intPosA - 1))
          Else
            strHeaderName = ""
        End If

        strHeaderValue = Trim$(Right$(strHeader, Len(strHeader) - intPosA))

        With Mails(MailCounter - 1)

            Select Case LCase$(strHeaderName)
              Case "from"
                .from = DecodeIso(strHeaderValue)
              Case "to"
                .To = DecodeIso(strHeaderValue)
              Case "subject"
                .Subject = DecodeIso(strHeaderValue)
              Case "date"
                .Date = DecodeIso(strHeaderValue)
            End Select
        End With
    Next  'VFIELD INTTEMP

    intFrom = 0
    intTo = 0

    Mails(MailCounter - 1).Size = Len(m_strMessageText)
    Mails(MailCounter - 1).Header = m_strHeaders


'+++++++++++++++++++++ All Headers Processed, now decode the Mail!++++++++++++++++++
    'Load the Mail line by line into an array
    strlines = Split(m_strMessageText, vbCrLf)

    'Free some Memory
    m_strMessageText = ""
    m_strHeaders = ""

    'Search for Attachments
    Boundary = "boundary="

    intPosA = findLine(0, Boundary, strlines(), True)

    'Check if the Mail have Mime Attachments
    If intPosA = -1 Then
        GoTo Plaintext
    End If

    'Get all boundary Strings
    Do Until intPosA = -1
        intPosA = findLine(intPosA, Boundary, strlines(), True)

        If intPosA <> -1 Then
            strTemp = GetInfo(intPosA, Boundary, strlines())
            BoundaryVal = BoundaryVal + " " + "--" + strTemp
            intPosA = intPosA + 1
        End If

    Loop

    'Convert to Array
    BoundArray = Split(Trim$(BoundaryVal), " ")

    intFrom = LBound(BoundArray)
    intTo = UBound(BoundArray)

    'Now we extract all Attachments!
    intTemp = findLine(0, Boundary, strlines())
    
    For Counter2 = intFrom To intTo

        BoundaryVal = BoundArray(Counter2)

        intPosA = intTemp

        'Search Last Boundary
        EndBoundary = RevfindLine(BoundaryVal + "--", strlines())
        
        If EndBoundary = -1 Then
            EndBoundary = RevfindEmptyLine(strlines())
        End If

        Do Until intPosA >= EndBoundary

            intPosA = findLine(intPosA, BoundaryVal, strlines())
            intPosB = findLine(intPosA + 1, BoundaryVal, strlines())
            
            If intPosB = -1 Then
                intPosB = RevfindEmptyLine(strlines())
            End If
            
            intPos = findLine(intPosA, "Content-Type:", strlines())

            'Prevent extracting several "Sub"Attachments
            If intPos <> -1 Then
                If InStr(LCase$(strlines(intPos)), "boundary=") > 0 Then
                    GoTo Skip
                End If
            End If

            'Extract Attachment

            'First copy Mail to temp Array
            ptSpan = strlines

            'Move temp Array to destination array
            MoveStringArray ptSpan, strLine, intPosA + 1, intPosB - 1

            intCount = 0

            'This Part should be worked out => please Mail me your suggestions

            'It's pure US Plaintext
            If intPos = -1 Then
                TmpString = DecodeAttachment(strLine)
                Mails(MailCounter - 1).Message = TmpString

                GoTo Skip
            End If

            If InStr(LCase$(strlines(intPos)), "text/html") > 0 Then

                TmpString = DecodeAttachment(strLine)
                Mails(MailCounter - 1).HTMLMessage = TmpString
                GoTo Skip
            End If

            If InStr(LCase$(strlines(intPos)), "text") > 0 Then
                TmpString = DecodeAttachment(strLine)
                Mails(MailCounter - 1).Message = TmpString
                GoTo Skip
            End If

            If InStr(LCase$(strlines(intPos)), "multipart") > 0 Then
                TmpString = DecodeAttachment(strLine)
                Mails(MailCounter - 1).Message = TmpString
                GoTo Skip
            End If

            'Search the Filename
            intPos = findEmptyLine(0, strLine)

            If intPos <> -1 Then
                MimeHeaders = UnfoldArray(0, intPos, strLine)
                intPos = findLine(0, "name=", MimeHeaders, True)
                strFilename = GetInfo(intPos, "name=", MimeHeaders)
              Else
                intPos = findLine(0, "name=", strLine(), True)
                strFilename = GetInfo(intPos, "name=", strLine())
            End If

            strFilename = DecodeIso(strFilename)

            If strFilename = "" Then
                strFilename = "unnamed"
            End If

            'Save Attachment
            AddAttachment MailCounter - 1, strLine, strFilename
            AttachmentCounter = AttachmentCounter + 1

Skip:
            intPosA = intPosB
        Loop

    Next Counter2
    
    AttachmentCounter = 0

Exit Sub

Plaintext:

    intPos = findLine(1, "Content-Type:", strlines())

    m_strMessageBody = DecodeAttachment(strlines())

    If intPos > 0 Then
        If InStr(LCase$(strlines(intPos)), "text/html") > 0 Then
            Mails(MailCounter - 1).HTMLMessage = m_strMessageBody
          Else

            Mails(MailCounter - 1).Message = m_strMessageBody
        End If

      Else
        'Save the E-Mail
        Mails(MailCounter - 1).Message = m_strMessageBody
    End If

    AttachmentCounter = 0

    Erase strlines

End Sub

Public Function DecodeAttachment(ByRef Encoded() As String) As String

  Dim tmpEncoding   As String
  Dim tmpAttachment As String
  Dim intPosA       As Long
  Dim intPosB       As Long
  'Dim Counter       As Long
  Dim tmplong       As Long
  Dim Attachment() As String

    On Error GoTo error

    Attachment = Encoded

    tmplong = UBound(Attachment)

    If Not tmplong > 0 Then
        DecodeAttachment = ""
        Exit Function
    End If

    '1. What kind of Attachment is it?

    'Get Encoding-Type
    intPosA = findLine(0, "Content-Transfer-Encoding:", Attachment())

    If intPosA <> -1 Then
        tmpEncoding = GetInfo(intPosA, "Content-Transfer-Encoding:", Attachment())
      Else
        intPosA = 0
    End If

    'After the empty line the attachment waits for us!
    intPosA = findEmptyLine(intPosA, Attachment()) + 1

    'Extract Attachment

    '2. Decode it

    Select Case True
      Case InStr(LCase$(tmpEncoding), "base64") > 0

        'Very Fast Array Copy Routine (about 10x)!
        MoveStringArray Attachment, ptSpan, intPosA, tmplong

        tmpAttachment = Join(ptSpan, "")
        'tmpEncoding = tmpAttachment
        
        '2x times  faster (65 ms 120 ms)
        tmpAttachment = Decode(tmpAttachment)
        
        
      Case InStr(LCase$(tmpEncoding), "x-uue") > 0

        tmplong = RevfindLine("end", Attachment) - 1

        If tmplong = -1 Then
            tmplong = UBound(Attachment)
        End If
        
        'Very Fast Array Copy Routine (about 10x)!
        MoveStringArray Attachment, ptSpan, intPosA, tmplong

        
        intPosB = 0

        tmpAttachment = Join(ptSpan, vbCrLf)

        tmpAttachment = Replace(tmpAttachment, Chr$(0), "")

        tmpAttachment = DecodeUUE(tmpAttachment)

      Case InStr(LCase$(tmpEncoding), "quoted-printable") > 0

        'Very Fast Array Copy Routine (about 10x)!
        MoveStringArray Attachment, ptSpan, intPosA, tmplong

        tmpAttachment = Join(ptSpan, "=_")

        tmpAttachment = Replace(tmpAttachment, Chr$(0), "")

        tmpAttachment = DecodeQP(tmpAttachment)

      Case Else

        'Very Fast Array Copy Routine (about 10x)!
        MoveStringArray Attachment, ptSpan, intPosA, tmplong

        tmpAttachment = Join(ptSpan, vbCrLf)

        tmpAttachment = Replace(tmpAttachment, Chr$(0), "")

    End Select

    DecodeAttachment = tmpAttachment
    Erase ptSpan


Exit Function

error:
    DecodeAttachment = ""

End Function

'Saves the attachment into an UDT
Private Sub AddAttachment(intMail As Integer, strLine() As String, strFilename As String)

  Dim intElements As Integer
  Dim intBlockSize As Integer
  Dim intCounter As Integer

    On Error GoTo error

    intCounter = Mails(intMail).AttachedFiles + 1

    intElements = UBound(Mails(intMail).Attachments())

    If intElements > 0 Then

        intBlockSize = 10

        If intCounter - 1 > intElements Then
            ReDim Preserve Mails(intMail).Attachments(intElements + intBlockSize)
        End If

      Else
        'Initiate the Mail UDT for the first time
error:
        intBlockSize = 10
        ReDim Mails(intMail).Attachments(intBlockSize - 1)
    End If

    intElements = UBound(Mails(intMail).Attachments())

    'Save Attachment
    Mails(intMail).Attachments(intCounter - 1).Data = strLine
    Mails(intMail).Attachments(intCounter - 1).Name = DecodeIso(strFilename)
    Mails(intMail).AttachedFiles = intCounter

End Sub

'Clear all Mails
Public Sub ClearMails()

    Erase Mails

End Sub

''**************************************************************************************
' Base64 Decode
'
' This is an optimized version of the common Base 64 encode/decode.
' This version eliminates the repeditive calls to chr$() and asc(),
' as well as the linear searches I've seen in some routines.
'
' This method does use a bit more memory in permanent lookup tables
' than most do.  However, this eliminates the need for using vb's
' rather slow method of bit shifting (multiplication and division).
' This appears not to make much difference in the IDE, but make
' a huge difference in the exe.
'   Encodeing Index = 834 vs. 64 bytes standard
'   Decoding Index  = 1536 vs. 64 to 256 standard
'
' This routine also adds the CrLf on the fly rather than making
' a temporary copy of the encoded string then adding the crlf
'
' Encoding/Decoding data from and to a file should be changed to
' use a fixed buffer to reduce the memory requirements of EncodeFile, etc.
'
' All of this results in a speed increase:
'   Encode:
'         100 reps on a string of 28311 bytes
'                               IDE      EXE
'   Base64                      2824     300 (220 w/no overflow & array bound checks)
'   Base64a (unknown author)  375500* 185300*
'   Base64b (Wil Johnson)       2814     512 (410 w/no overflow & array bound checks)
'     *Extrapolated (based on 1 rep, I didn't have time to wait 30 minutes for 100)
'     *Unknown code is from ftp:altecdata.com/base64.cls
'
'  Decode
'         100 reps on a string of 28311 bytes
'                              IDE    EXE
'   Base64                    3384     351 (271 w/no overflow & array bound checks)
'   Base64a (unknown author)
'   Base64b (Wil Johnson)     5969    1191 (981 w/no overflow & array bound checks)
'   *Failed
'   *Unknown code is from ftp:altecdata.com/base64.cls
'
'
' Author: Tim Arheit - [e-mail]
' Version: 1.0
'
' This code is provided as-is.  You are free to use and modify it
' as you wish.  Please report bugs, fixes and enhancements to the
' author.
'
' History:
'    11/13/00 - Code release. It appears to work.
'
'   09/02/02 I clean the source code and remove the encoding routines

'Decode a string to a string.
Public Function Decode(sInput As String) As String

  Dim bTemp() As Byte

    'Convert to a byte array then convert.
    'This is faster the repetitive calls to asc() or chr$()
    bTemp = StrConv(sInput, vbFromUnicode)

    Decode = StrConv(DecodeArr(bTemp), vbUnicode)

End Function

Public Sub DecodeToFile(sInput As String, sOutputFile As String)

  Dim bTemp() As Byte
  Dim fh As Long

    bTemp = StrConv(sInput, vbFromUnicode)
    bTemp = DecodeArr(bTemp)

    fh = FreeFile(0)
    Open sOutputFile For Binary Access Write As fh
    Put fh, , bTemp
    Close fh

End Sub

Public Sub DecodeFile(sInputFile As String, sOutputFile As String)