VBA Tipp: Base64-Kodierung

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte per Programm Daten entsprechend RFC 2045 kodieren / dekodieren (Base64-Kodierung)

Lösung

Das leistet das folgende Klassenmodul:

Option Explicit
 
Private EncodeArr(64) As String * 1
Private DecodeArr(255) As Byte
Private Const EncChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
                         "abcdefghijklmnopqrstuvwxyz" & _
                         "0123456789+/"
 
Property Get Encode(strIn As String) As String
   Dim strOut As String
   Dim a(2)  As Byte
   Dim n0    As Long
   Dim n1    As Long
   Dim n2    As Long
   Dim N3    As Long
   Dim ausg  As Long
   Dim i     As Long
   Dim j     As Long
 
   i = 1: ausg = 3
   Do While i <= Len(strIn)
      For j = 0 To 2
         If i <= Len(strIn) Then
            a(j) = Asc(Mid$(strIn, i, 1)): i = i + 1
         Else
            a(j) = 0: ausg = ausg - 1
         End If
      Next
      n0 = (a(0) \ 4) And &H3F
      n1 = ((a(0) * 16) And &H30) + ((a(1) \ 16) And &HF)
      n2 = ((a(1) * 4) And &H3C) + ((a(2) \ 64) And &H3)
      N3 = a(2) And &H3F
      strOut = strOut & EncodeArr(n0) & EncodeArr(n1) & _
               IIf(ausg > 1, EncodeArr(n2), "=") & IIf(ausg > 2, EncodeArr(N3), "=")
   Loop
   Encode = strOut
End Property
 
Property Get Decode(strIn As String) As String
   Dim strOut As String
   Dim a0     As Long
   Dim a1     As Long
   Dim a2     As Long
   Dim a3     As Long
   Dim b0     As Long
   Dim b1     As Long
   Dim b2     As Long
   Dim b3     As Long
   Dim i      As Long
 
   For i = 1 To Len(strIn) - 3 Step 4
      b0 = Asc(Mid$(strIn, i, 1)):     a0 = DecodeArr(b0)
      b1 = Asc(Mid$(strIn, i + 1, 1)): a1 = DecodeArr(b1)
      b2 = Asc(Mid$(strIn, i + 2, 1)): a2 = DecodeArr(b2)
      b3 = Asc(Mid$(strIn, i + 3, 1)): a3 = DecodeArr(b3)
      strOut = strOut & Chr$(((a0 * 4) Or (a1 \ 16)) And &HFF)
      If b2 <> Asc("=") Then strOut = strOut & Chr$(((a1 * 16) Or (a2 \ 4)) And &HFF)
      If b3 <> Asc("=") Then strOut = strOut & Chr$(((a2 * 64) Or a3) And &HFF)
   Next
   Decode = strOut
End Property
 
Private Sub Class_Initialize()
   Dim i  As Long
   Dim ch As String
 
   For i = 0 To 255: DecodeArr(i) = 0: Next
   For i = 1 To Len(EncChars)
      ch = Mid$(EncChars, i, 1)
      EncodeArr(i - 1) = ch
      DecodeArr(Asc(ch)) = i - 1
   Next
End Sub

Aufruf

   Dim Base64 As New clsBase64
 
   Open "test.b64" For Output As #1
   Print #1, Base64.encode(Me!MeinFeld)
   Close #1

Bemerkungen

  • Siehe auch die Beispieldatenbank Base64
  • Zur Definition der Base64-Kodierung siehe RFC 2045