Zurück zur Homepage

Base64

Base64 dient zur Übertragung von 8-Bit Daten in der 7-Bit Welt von E-Mail.
Da man normalerweise E-Mailprogramme hat, die Base64 (Anhänge) beherrschen, war ich der Meinung, dass mein Code nie zum Einsatz kommen wird. In der Excel NG ist aber jetzt eine Frage aufgetaucht, wie man Excel-Dateien als E-Mail Anhang versenden und empfangen kann, ohne dass die Firewall oder Virenscanner meckert. Das müsste ohne Probleme gehen, wenn die Excel-Datei vorher in eine Base64-Codierte Textdatei umgewandelt wird. Das E-Mailprogramm encodiert die entstandene Textdatei nochmals mit Base64, so dass ein Virenscanner, der den Anhang decodiert, nur eine weitere Base64-Textdatei vor sich hat. Diese Ansammlung von reinem Text dürfte ohne Probleme durchgelassen werden.
Base64 enthält 64 verschiedene Symbole aus dem ASCII-Zeichensatz mit einer Wertigkeit von 0 bis 63, die dann übertragen werden. 3 Bytes werden in 4 Symbole des Base64-Systems umgewandelt. (3 Bytes a' 8 Bit = 4 Symbole a' 6 Bit) Die Datei wird dabei um 33% größer.
Da man mit Dreiergruppen arbeitet kann es passieren, dass die letzte Dreiergruppe nicht voll wird. Dann werden Gleichheitszeichen angefügt.

Beispieldatei (base64wandler.zip 16 KB)

Option Explicit
Public Sub Encodieren()
Dim strFile As String
Dim lngFF   As Long
Dim strBuff As String

'Pfad zur Excel-Datei erfragen
strFile = Application.GetOpenFilename("Excel Files (*.xls),*.xls", _
   , "Exceldateien nach Base64")
    
'Abbrechen, wenn nichts ausgewählt
If (LCase(strFile) = "falsch") Or (LCase(strFile) = "false") Then _
   Exit Sub
   
'Freie Filenummer ermitteln
lngFF = FreeFile

Open strFile For Binary Access Read As lngFF
    'Dateiinhalt in strBuffer einlesen
    strBuff = String(LOF(lngFF), 0)
    Get lngFF, , strBuff
Close

strFile = Application.GetSaveAsFilename("Base64-" & Hour(Now) & _
    Minute(Now) & Second(Now), "Text Files (*.txt),*.txt", _
    , "Speichern als Textdatei")
    
'Abbrechen, wenn nichts ausgewählt
If (LCase(strFile) = "falsch") Or (LCase(strFile) = "false") Then Exit Sub

'Löschen, wenn Datei vorhanden
If Dir(strFile) <> "" Then Kill strFile

Open strFile For Binary As lngFF
   'strBuffer encodieren und in File schreiben
   strBuff = Base64(strBuff)
   Put lngFF, , strBuff
Close
End Sub


Public Sub Decodieren()
Dim strFile As String
Dim lngFF   As Long
Dim strBuff As String

'Pfad zur Text-Datei erfragen
strFile = Application.GetOpenFilename("Text Files (*.txt),*.txt", _
   , "Textdateien nach Excel")
    
'Abbrechen, wenn nichts ausgewählt
If (LCase(strFile) = "falsch") Or (LCase(strFile) = "false") Then _
   Exit Sub

'Freie Filenummer ermitteln
lngFF = FreeFile

Open strFile For Binary Access Read As lngFF
    strBuff = String(LOF(lngFF), 0)
    Get lngFF, , strBuff
Close

strFile = Application.GetSaveAsFilename("Excel-" & Hour(Now) & _
   Minute(Now) & Second(Now), "Excel Files (*.xls),*.xls", _
   , "Speichern als Exceldatei")
   
'Abbrechen, wenn nichts ausgewählt
If (LCase(strFile) = "falsch") Or (LCase(strFile) = "false") Then _
   Exit Sub

'Löschen, wenn Datei vorhanden
If Dir(strFile) <> "" Then Kill strFile

Open strFile For Binary As lngFF
    'strBuffer decodieren und in File schreiben
    strBuff = DecodeBase64(strBuff)
    Put lngFF, , strBuff
Close

End Sub


Public Function Base64(Text As String) As String
'Base64 dient zur Übertragung von 8-Bit Daten in der
'7-Bit Welt von E-Mail. Dieses System benutzt 64
'verschiedene Symbole aus dem ASCII-Zeichensatz, die
'dann übertragen werden.
'3 Bytes werden in 4 Symbole des Base64-Systems umgewandelt.
'(3 Bytes a' 8 Bit = 4 Symbole a' 6 Bit)
'Da man mit Dreiergruppen arbeitet kann es passieren, dass
'die letzte Dreiergruppe nicht voll wird. Dann werden
'Gleichheitszeichen angefügt.
Dim abytSourceCode() As Byte
Dim lngPos           As Long
Dim lngDummy         As Long
Dim abytSource()     As Byte
Dim abytDest()       As Byte
Dim lngLen           As Long
Dim i                As Long
Dim lngDiff          As Long

'Das sind die 64 Textsymbole
abytSourceCode = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
   "abcdefghijklmnopqrstuvwxyz0123456789+/", _
   vbFromUnicode)
    
'Anzahl Bytes
lngLen = Len(Text)

'Wenn durch 3 nicht ohne Rest teilbar, lngDifferenz ermitteln
lngDiff = (lngLen - (lngLen \ 3) * 3) + _
   ((lngLen - (lngLen \ 3) * 3) = 2) - _
   ((lngLen - (lngLen \ 3) * 3) = 1)
    
'lngDifferenz an Text anhängen, damit es aufgeht
Text = Text + String(lngDiff, 0)

'TextstrBuffer in Array umwandeln
abytSource = StrConv(Text, vbFromUnicode)

'Länge Zielarray ermitteln
i = ((lngLen \ 3) - (lngDiff > 0)) * 4

'und erzeugen
ReDim abytDest(0 To i - 1)
lngLen = UBound(abytDest)

'Jeweils drei Bytes umwandeln
For i = 0 To UBound(abytSource) - 1 Step 3
   lngPos = (i \ 3) * 4
   
   'Drei Bytes in ein Long packen
   lngDummy = abytSource(i) * &H10000 + abytSource(i + 1) * _
      &H100& + abytSource(i + 2)
      
   'Die unteren 6 Bits bestimmen das Zeichen
   abytDest(lngPos + 3) = abytSourceCode(lngDummy And &H3F&)
   
   '6 Bits nach rechts schieben und die unteren 6 herausholen
   abytDest(lngPos + 2) = abytSourceCode( _
      (lngDummy \ &H40&) And &H3F&)
   
   '6 Bits nach rechts schieben und die unteren 6 herausholen
   abytDest(lngPos + 1) = abytSourceCode( _
      (lngDummy \ &H1000&) And &H3F&)
   
   '6 Bits nach rechts schieben und die unteren 6 herausholen
   abytDest(lngPos) = abytSourceCode( _
      (lngDummy \ &H40000) And &H3F&)
   
Next

'Jetzt die Gleichheitszeichen
For i = lngLen To lngLen + 1 - lngDiff Step -1
   abytDest(i) = 61
Next

'Umwandeln in Text und zurückgeben
Base64 = StrConv(abytDest, vbUnicode)
End Function


Public Function DecodeBase64(Text As String) As String
Dim abytDummy()               As Byte
Dim lngPos                    As Long
Dim abytSource()              As Byte
Dim abytDest()                As Byte
Dim abytSourceCode(0 To 255)  As Byte
Dim i                         As Long

'Das sind die 64 Textsymbole
abytDummy = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
   "abcdefghijklmnopqrstuvwxyz0123456789+/", _
   vbFromUnicode)
    
'Die 64 Zeichen haben den Index 0-63
'abytDummy(0) ist das Zeichen "A", das
'heißt, es enthält den Ascii-Code von "A".
'Das Element abytSourceCode(abytDummy(0)),
'also das mit dem Index des ASCII-Codes "A"
'bekommt jetzt den Wert Null zugewiesen
'abytSourceCode(abytDummy(1)) wird 1 etc.
For i = 0 To 63
   abytSourceCode(abytDummy(i)) = i
Next

'TextBuffer in Array umwandeln
abytSource = StrConv(Text, vbFromUnicode)

'Länge Zielarray ermitteln und erzeugen
ReDim abytDest(0 To (Len(Text) \ 4) * 3 - 1)

'Jeweils vier 6 Bit Zeichen in drei Bytes umwandeln
For i = 0 To UBound(abytSource) - 1 Step 4
   lngPos = (i \ 4) * 3
   abytDest(lngPos) = (abytSourceCode(abytSource(i)) * 4) Or _
      (abytSourceCode(abytSource(i + 1)) \ 16)
   abytDest(lngPos + 1) = ((abytSourceCode(abytSource(i + 1)) _
      And 15) * 16) Or (abytSourceCode(abytSource(i + 2)) \ 4)
   abytDest(lngPos + 2) = ((abytSourceCode(abytSource(i + 2)) _
      And 3) * 64) Or abytSourceCode(abytSource(i + 3))
Next

If Right$(Text, 1) = "=" Then
   If Mid$(Text, Len(Text) - 1, 1) = "=" Then
      i = 2
   Else
      i = 1
   End If
   ReDim Preserve abytDest(0 To UBound(abytDest) - i)
End If

'Umwandeln in Text und zurückgeben
DecodeBase64 = StrConv(abytDest, vbUnicode)
End Function