vbmime.cls

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

  Dim bTemp() As Byte
  Dim fh As Long

    fh = FreeFile(0)
    Open sInputFile For Binary Access Read As fh
    ReDim bTemp(0 To LOF(fh) - 1)
    Get fh, , bTemp
    Close fh

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

End Sub


Private Function DecodeArr(bInput() As Byte) As Byte()

  Dim bOutput() As Byte
  Dim OutLength As Long
  Dim CurrentOut As Long

  Dim k As Long
  Dim l As Long
  Dim I As Long
  

  Dim b As Byte
  Dim c As Byte
  Dim d As Byte
  Dim e As Byte

    k = LBound(bInput)
    l = UBound(bInput)

    'Calculate the length of the input
    I = l - k + 1

    'Allocate the output

  Dim BytesDataIn As Long ':(燤ove line to top of current Function
  Dim BytesDataOut As Long ':(燤ove line to top of current Function
  Dim ExtraBytes As Integer ':(燤ove line to top of current Function

    If bInput(l) = 61 Then
        ExtraBytes = 1
        If bInput(l - 1) = 61 Then
            ExtraBytes = 2
        End If
    End If

    BytesDataIn = l + 1 'BytesDataIn of the string
    BytesDataOut = (BytesDataIn * 0.75) - ExtraBytes ' how many bytes will the decoded string have

    ReDim bOutput(BytesDataOut - 1)

    CurrentOut = 0

    For I = k To l
        Select Case bInput(I)
          Case CHAR_CR
            'Do nothing
          Case CHAR_LF
            'Do nothing
          Case Else
            If l - I >= 3 Then
                b = bInput(I)
                c = bInput(I + 1)
                d = bInput(I + 2)
                e = bInput(I + 3)

                If e <> CHAR_EQUAL Then
                    bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
                    bOutput(CurrentOut + 1) = m_ReverseIndex2(c, 1) Or m_ReverseIndex3(d, 0)
                    bOutput(CurrentOut + 2) = m_ReverseIndex3(d, 1) Or m_ReverseIndex4(e)
                    CurrentOut = CurrentOut + 3
                    I = I + 3 ':(燤odifies active For-Variable
                  ElseIf d <> CHAR_EQUAL Then 'NOT E...
                    bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
                    bOutput(CurrentOut + 1) = m_ReverseIndex2(c, 1) Or m_ReverseIndex3(d, 0)
                    CurrentOut = CurrentOut + 2
                    I = I + 3 ':(燤odifies active For-Variable
                  Else 'NOT D...
                    bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
                    CurrentOut = CurrentOut + 1
                    I = I + 3 ':(燤odifies active For-Variable
                End If

              Else 'NOT L...
                'Possible input code error, but may also be
                'an extra CrLf, so we will ignore it.
            End If
        End Select
    Next I

    'On properly formed input we should have to do this.
    If OutLength <> CurrentOut + 1 Then
        ReDim Preserve bOutput(0 To CurrentOut - 1)
    End If

    DecodeArr = bOutput

End Function




'Saves a String to a File
Public Sub SaveStr2File(strInput As String, strPathName As String)

  Dim iFreeFile As Integer

    '-----
    ' Reference to a free file
    '-----
    iFreeFile = FreeFile
    Open strPathName For Binary As iFreeFile
    '-----
    ' Save the total size of the array in a variable, this stops
    ' VB to calculate the size each time it comes into the loop,
    ' which of course, takes (much) more time then this sollution
    '-----

    Put iFreeFile, , strInput

    Close iFreeFile

End Sub

'==========
' StrToAry;
' Convert the string into a byte array
'==========
Public Sub StringToByteArray(ByVal strIn As String, ByRef pbArrayOutput() As Byte)

    pbArrayOutput = StrConv(strIn, vbFromUnicode)

End Sub

'==========
' AryToSr;
' Convert the byte array into a string
'==========
Public Sub ByteArrayToString(ByRef pbArrayInput() As Byte, ByRef strOut As String)

    strOut = StrConv(pbArrayInput, vbUnicode)

End Sub



Public Function StringArrayToString(pbIn() As String) As String

  Dim lSize     As Long
  Dim lNow      As Long
  Dim lTotal    As Long
  Dim lNowArray As Long
  Dim lNow2     As Long
  Dim lTotal2   As Long
  Dim tTemp     As String
  Dim bTemp()   As Byte

    '-----
    ' Calculate size of inputarray
    '-----
    lSize = 0
    lTotal = UBound(pbIn)
    For lNow = 0 To lTotal
        lSize = lSize + Len(pbIn(lNow))
    Next lNow

    '-----
    ' Create byte array which is big
    ' enough to hold all the bytes
    '-----
    ReDim bTemp(0 To lSize)

    '-----
    ' Convert the string array to a byte array
    '-----
    lNow = 0
    lNowArray = 0
    While lNow <> lSize
        tTemp = pbIn(lNowArray)
        lTotal2 = Len(tTemp)

        '-----
        ' Loop through the temp string
        ' and place the byte character
        ' in the correct position
        ' Mid$(...) is faster then Mid$(...)
        '-----
        For lNow2 = 0 To lTotal2 - 1
            bTemp(lNow + lNow2) = Asc(Mid$(tTemp, lNow2 + 1, 1))
        Next lNow2

        lNow = lNow + lTotal2
        lNowArray = lNowArray + 1
    Wend

    '-----
    ' Convert byte array to string
    '-----
    StringArrayToString = StrConv(bTemp(), vbUnicode)

End Function

'**************************************************************************************
'UUE decoding class
'
'Author: PSC
'
'Desc:
'
'This class have several routines that support the decoding UU
'encoded attachments
''**************************************************************************************

Public Function DecodeUUE(strUUCodeData As String) As String

  Dim vDataLine   As Variant
  Dim vDataLines  As Variant
  Dim strDataLine As String
  Dim intSymbols  As Integer
  Dim strTemp     As String
  Dim strUUDecode As String
  Dim I As Long

    On Error GoTo error

    'remove begin marker
    If Left$(strUUCodeData, 6) = "begin " Then
        strUUCodeData = Mid$(strUUCodeData, InStr(1, strUUCodeData, vbLf) + 1)
    End If
    '
    'remove end marker
    If Right$(strUUCodeData, 5) = "end" + vbCrLf Then
        strUUCodeData = Left$(strUUCodeData, Len(strUUCodeData) - 10)
    End If

    'Split encoded data to vDataLines array.
    'Now each array member contains a line of encoded data
    vDataLines = Split(strUUCodeData, vbCrLf)

    For Each vDataLine In vDataLines
        'Decode data line by line
        '
        strDataLine = CStr(vDataLine)

        If strDataLine = "" Then
            GoTo Skip
        End If

        'Get quantity of symbols in a line
        intSymbols = Asc(Left$(strDataLine, 1)) - 32
        'remove first symbol that just informs
        'about quantity of symbols
        strDataLine = Mid$(strDataLine, 2)
        'replace "`" with " "
        strDataLine = Replace(strDataLine, "`", " ")
        'Convert every 4-byte chunk to 3-byte chunk by
        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
        '
        strTemp = Left$(strTemp, intSymbols)
        'write decoded line to the file
        strUUDecode = strUUDecode + strTemp
        'clear buffer for next line
        strTemp = ""
Skip:
    Next vDataLine

    DecodeUUE = strUUDecode
error:

End Function

'**************************************************************************************
'Quoted printable decoding class
'
'Author: PSC
'
'Desc:
'
'This class have several routines that support the decoding of quoted printable
'encoded attachments
''**************************************************************************************

Public Function DecodeQP(ByRef StrToDecode As String) As String

  Dim sTemp As String
  Dim strChar As String
  Dim I As Integer

    sTemp = StrToDecode

    sTemp = Replace(sTemp, "==_", "")
    sTemp = Replace(sTemp, "=_", vbCrLf)

    For I = 255 To 16 Step -1
        strChar = UCase$(Hex$(I))
        If InStr(1, sTemp, "=" & strChar) <> 0 Then sTemp = Replace(sTemp, "=" & strChar, Chr$(I) + Chr$(0))
    Next I

    For I = 15 To 1 Step -1
        strChar = UCase$(Hex$(I))
        If InStr(1, sTemp, "=" & "0" & strChar) <> 0 Then
            sTemp = Replace(sTemp, "=" & "0" & strChar, Chr$(I) + Chr$(0))
        End If
    Next I

    sTemp = Replace(sTemp, Chr$(0), "")
    sTemp = Replace(sTemp, "=00", Chr$(0))
    sTemp = Replace(sTemp, Chr$(255) & Chr$(254), "=")

    DecodeQP = sTemp

End Function

'*************************************************************************************
'Function to decode ?iso? encoded Strings
'
'
'Author: David Bue Pedersen + Sebastian Fahrenkrog
'*************************************************************************************
Function DecodeIso(strEncoded As String)

  'Dim StrtoReplace As String
  'Dim StrReplacement As String
  Dim StringtoDecode As String
  Dim strLookup As String
  Dim b As Boolean

    On Error GoTo error

    StringtoDecode = strEncoded

    If IsNull(StringtoDecode) Then
        Exit Function
      ElseIf InStr(1, LCase$(StringtoDecode), "=?iso-") <= 0 Then
        DecodeIso = StringtoDecode
        Exit Function
    End If

  Dim IsoArray As Variant
  Dim UCounter As Integer
  Dim Counter As Integer
  Dim Pattern As String

    IsoArray = StringtoDecode
    IsoArray = Split(StringtoDecode, "?")

    UCounter = UBound(IsoArray)

    For Counter = 0 To UCounter
        strLookup = IsoArray(Counter)
        Select Case strLookup
          Case "="
          Case "= ="
          Case "=="
          Case "Q"
            b = False
          Case "B"
            b = True
          Case Else
            Pattern = "ISO-" & "[0-9]" & "[0-9]" & "[0-9]" & "[0-9]" & "-" & "*"
            If Not UCase(IsoArray(Counter)) Like Pattern Then
                If b Then 'Decode Base64
                    StringtoDecode = IsoArray(Counter)
                    StringtoDecode = Decode(StringtoDecode)
                    DecodeIso = DecodeIso + StringtoDecode
                  Else 'dann quoted printable
                    StringtoDecode = IsoArray(Counter)
                    StringtoDecode = DecodeQP(StringtoDecode)
                    DecodeIso = DecodeIso + StringtoDecode
                End If
            End If
        End Select
    Next Counter

Exit Function

error:
    'Return original String
    DecodeIso = strEncoded

End Function

Public Property Let DelMail(bolDeleteMail As Boolean)
    bolDelMail = bolDeleteMail
End Property

Public Property Get DelMail() As Boolean
    DelMail = bolDelMail
End Property

Private Function WaitUntilTrue(ByRef Flag As Boolean, ByVal SecondsToWait As Long, Optional ByVal bRaiseTimeOutError As Boolean = True) As Boolean

  Dim fStart              As Single
  Dim fTimetoQuit         As Single

    If SecondsToWait < 1 Then Exit Function

    fStart = Timer

    ' Deal with timer being reset at Midnight
    If fStart + SecondsToWait < 86400 Then
        fTimetoQuit = fStart + SecondsToWait
      Else
        fTimetoQuit = (fStart - 86400) + SecondsToWait
    End If

    Do Until Flag = True
        If Timer >= fTimetoQuit Then
            If bRaiseTimeOutError Then Timeout
            Exit Function
        End If
        If pbExitImmediately Then Exit Function
        DoEvents
        Sleep (10)                                  ' added to reduce CPU load during wait periods
    Loop

    WaitUntilTrue = Flag

End Function

Private Sub Timeout()

  ' time out occured
  
        'Hide Status
        RaiseEvent Pop3Status("")
        'Show Error
        RaiseEvent MimeFailed("Can't connect to the server!")
        Pop3sck.CloseSocket
        
        
End Sub