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:

Private encodeARR(64) As String * 1
Private decodeARR(255) As Byte
Private Const EncChars = _
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
 
Property Get encode(strIn As String) As String
Dim strOut As String, A(2) As Byte
Dim N0 As Long, N1 As Long, N2 As Long, N3 As Long
Dim Ausg As Long, i As Long, j As Long
 
  strOut = ""
  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 j
    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, A1 As Long, A2 As Long, A3 As Long
Dim B0 As Long, B1 As Long, B2 As Long, B3 As Long
Dim i  As Long
 
  strOut = ""
  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 i
  decode = strOut
End Property
 
Private Sub Class_Initialize()
Dim i As Long, ch As String
  For i = 0 To 255: decodeARR(i) = 0: Next i
  For i = 1 To Len(EncChars)
    ch = Mid(EncChars, i, 1)
    encodeARR(i - 1) = ch
    decodeARR(Asc(ch)) = i - 1
  Next i
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