base64.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "base64"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit

Private Const CHAR_EQUAL As Byte = 61
Private Const CHAR_CR As Byte = 13
Private Const CHAR_LF As Byte = 10

Private m_ReverseIndex1(0 To 255) As Byte
Private m_ReverseIndex2(0 To 255, 0 To 1) As Byte
Private m_ReverseIndex3(0 To 255, 0 To 1) As Byte
Private m_ReverseIndex4(0 To 255) As Byte


'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)

  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