[HELP] Base64 (VBA) simple function

[Whiroph]

Hello,
I'm Marco, this is my first post. I'm not english and sorry for my errors :P
I am writing to ask you to help.
I need two functions in VBA (for MS Access 2010) to encode and decode a Base64 string.
I googled but found only functions that are not complete or not really based on 64bit. Comparing them with many generators online, never gave the correct encoding.
Can anyone help me? Unfortunately I can not use external dll
thanks for any help

Marco

[LaVolpe]

Search Base64 in our CodeBank section of the forum. Complete samples do exist
Here's a link to one by a very reputable coder here. I based my current Base64 routines off of his.

[Elroy]

It's been forever since I've messed with this, but just something else in my "junk drawer":

Option Explicit
'
Private Const Equals As Byte = 61     ' Asc("=")
'
Private Const Mask1 As Byte = 3       ' 00000011
Private Const Mask2 As Byte = 15      ' 00001111
Private Const Mask3 As Byte = 63      ' 00111111
Private Const Mask4 As Byte = 192     ' 11000000
Private Const Mask5 As Byte = 240     ' 11110000
Private Const Mask6 As Byte = 252     ' 11111100
'
Private Const Shift2 As Byte = 4
Private Const Shift4 As Byte = 16
Private Const Shift6 As Byte = 64
'
Private Base64Lookup() As Byte
Private Base64Reverse() As Byte
'

Public Function bFileExists(fle As String) As Boolean
    On Error GoTo FileExistsError
    ' If no error then something existed.
    bFileExists = (GetAttr(fle) And vbDirectory) = 0
    Exit Function
FileExistsError:
    bFileExists = False
    Exit Function
End Function

Public Property Let StringToAsciiFile(sFileSpec As String, sStr As String)
    ' If file exists, this will fail.
    Dim iFle As Long
    '
    If bFileExists(sFileSpec) Then Exit Property
    iFle = FreeFile
    On Error Resume Next
    Open sFileSpec For Output As iFle
    If Err <> 0 Then Close iFle: Exit Property
    On Error GoTo 0
    Print #iFle, sStr;
    Close iFle
End Property

Public Function AsciiFileToString(sFileSpec As String) As String
    Dim iFle As Long
    '
    If Not bFileExists(sFileSpec) Then Exit Function
    iFle = FreeFile
    On Error Resume Next
    Open sFileSpec For Binary As iFle
    If Err <> 0 Then Close iFle: Exit Function
    On Error GoTo 0
    If Len(iFle) = 0 Then Close iFle: Exit Function
    '
    ' For variable length strings, the number of bytes read equals the number of characters already in the string.
    AsciiFileToString = Space(LOF(iFle))
    Get iFle, 1, AsciiFileToString
    Close iFle
End Function

Public Function EncodeString(Text As String) As String
    Dim Data() As Byte
    '
    Initialize
    Data = StrConv(Text, vbFromUnicode)
    EncodeString = EncodeByteArray(Data)
End Function

Public Function EncodeByteArray(Data() As Byte) As String
    Dim EncodedData() As Byte
    Dim DataLength As Long
    Dim EncodedLength As Long
    Dim Data0 As Long
    Dim Data1 As Long
    Dim Data2 As Long
    Dim l As Long
    Dim m As Long
    Dim Index As Long
    Dim CharCount As Long
    '
    Initialize
    DataLength = UBound(Data) + 1
    '
    EncodedLength = (DataLength \ 3) * 4
    If DataLength Mod 3 > 0 Then EncodedLength = EncodedLength + 4
    EncodedLength = EncodedLength + ((EncodedLength \ 76) * 2)
    If EncodedLength Mod 78 = 0 Then EncodedLength = EncodedLength - 2
    ReDim EncodedData(EncodedLength - 1)
    '
    m = (DataLength) Mod 3
    '
    For l = 0 To UBound(Data) - m Step 3
        Data0 = Data(l)
        Data1 = Data(l + 1)
        Data2 = Data(l + 2)
        EncodedData(Index) = Base64Lookup(Data0 \ Shift2)
        EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
        EncodedData(Index + 2) = Base64Lookup(((Data1 And Mask2) * Shift2) Or (Data2 \ Shift6))
        EncodedData(Index + 3) = Base64Lookup(Data2 And Mask3)
        Index = Index + 4
        CharCount = CharCount + 4
        '
        If CharCount = 76 And Index < EncodedLength Then
            EncodedData(Index) = 13
            EncodedData(Index + 1) = 10
            CharCount = 0
            Index = Index + 2
        End If
    Next l
    '
    If m = 1 Then
        Data0 = Data(l)
        EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
        EncodedData(Index + 1) = Base64Lookup((Data0 And Mask1) * Shift4)
        EncodedData(Index + 2) = Equals
        EncodedData(Index + 3) = Equals
        Index = Index + 4
    ElseIf m = 2 Then
        Data0 = Data(l)
        Data1 = Data(l + 1)
        EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
        EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
        EncodedData(Index + 2) = Base64Lookup((Data1 And Mask2) * Shift2)
        EncodedData(Index + 3) = Equals
        Index = Index + 4
    End If
    '
    EncodeByteArray = StrConv(EncodedData, vbUnicode)
End Function

Public Function DecodeToString(EncodedText As String) As String
    Dim Data() As Byte
    '
    Initialize
    Data = DecodeToByteArray(EncodedText)
    DecodeToString = StrConv(Data, vbUnicode)
End Function

Public Function DecodeToByteArray(EncodedText As String) As Byte()
    Dim Data() As Byte
    Dim EncodedData() As Byte
    Dim DataLength As Long
    Dim EncodedLength As Long
    Dim EncodedData0 As Long
    Dim EncodedData1 As Long
    Dim EncodedData2 As Long
    Dim EncodedData3 As Long
    Dim l As Long
    Dim m As Long
    Dim Index As Long
    Dim CharCount As Long
    '
    Initialize
    ' Remove CRLF and "=" characters.
    EncodedData = StrConv(Replace$(Replace$(EncodedText, vbCrLf, ""), "=", ""), vbFromUnicode)
    '
    EncodedLength = UBound(EncodedData) + 1
    DataLength = (EncodedLength \ 4) * 3
    '
    m = EncodedLength Mod 4
    If m = 2 Then
        DataLength = DataLength + 1
    ElseIf m = 3 Then
        DataLength = DataLength + 2
    End If
    '
    ReDim Data(DataLength - 1)
    '
    For l = 0 To UBound(EncodedData) - m Step 4
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        EncodedData2 = Base64Reverse(EncodedData(l + 2))
        EncodedData3 = Base64Reverse(EncodedData(l + 3))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
        Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
        Data(Index + 2) = ((EncodedData2 And Mask1) * Shift6) Or EncodedData3
        Index = Index + 3
    Next l
    '
    Select Case ((UBound(EncodedData) + 1) Mod 4)
    Case 2
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
    Case 3
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        EncodedData2 = Base64Reverse(EncodedData(l + 2))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
        Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
    End Select
    '
    DecodeToByteArray = Data
End Function

Private Sub Initialize()
    Dim l As Long
    Static bInitialized As Boolean
    '
    If bInitialized Then Exit Sub
    ReDim Base64Reverse(255)
    Base64Lookup = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
    For l = 0 To 63
        Base64Reverse(Base64Lookup(l)) = l
    Next l
    bInitialized = True
End Sub

p.s. The name of the module was Base64MimeCoding.bas.

[Elroy]

Here's a document that I typed to myself and last updated who knows how long ago:

Base64 Encoding Algorithm

Base64 algorithm is designed to encode any binary data, a stream of bytes, into a stream of 64-printable characters.

Base64 encoding algorithm was first presented in "RFC 1421 - Privacy Enhancement for Internet Electronic Mail: Part I: Message Encryption and Authentication Procedures" in 1993 by John Linn. It was later modified slightly in "RFC 1521 - MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies" in September 1993 by N. Borenstein, et al..

The 64 printable characters used by Base64:
Value Encoding Value Encoding Value Encoding Value Encoding
0 A 17 R 34 i 51 z
1 B 18 S 35 j 52 0
2 C 19 T 36 k 53 1
3 D 20 U 37 l 54 2
4 E 21 V 38 m 55 3
5 F 22 W 39 n 56 4
6 G 23 X 40 o 57 5
7 H 24 Y 41 p 58 6
8 I 25 Z 42 q 59 7
9 J 26 a 43 r 60 8
10 K 27 b 44 s 61 9
11 L 28 c 45 t 62 +
12 M 29 d 46 u 63 /
13 N 30 e 47 v
14 O 31 f 48 w
15 P 32 g 49 x
16 Q 33 h 50 y
The encoding process is to:

• Divide the input bytes stream into blocks of 3 bytes.
• Divide the 24 bits of a 3-byte block into 4 groups of 6 bits.
• Map each group of 6 bits to 1 printable character, based on the 6-bit value.
• If the last 3-byte block has only 1 byte of input data, pad 2 bytes of zero (\x0000). After encoding it as a normal block, override the last 2 characters with 2 equal signs (==), so the decoding process knows 2 bytes of zero were padded.
• If the last 3-byte block has only 2 bytes of input data, pad 1 byte of zero (\x00). After encoding it as a normal block, override the last 1 character with 1 equal signs (=), so the decoding process knows 1 byte of zero was padded.
• Carriage return (\r) and new line (\n) are inserted into the output character stream. They will be ignored by the decoding process.

Example 1: Input data, 1 byte, "A". Encoded output, 4 characters, "QQ=="
Input Data A
Input Bits 01000001
Padding 01000001 00000000 00000000
\ \ \
Bit Groups 010000 010000 000000 000000
Mapping Q Q A A
Overriding Q Q = =

Example 2: Input data, 2 bytes, "AB". Encoded output, 4 characters, "QUI="
Input Data A B
Input Bits 01000001 01000010
Padding 01000001 01000010 00000000
\ \ \
Bit Groups 010000 010100 001000 000000
Mapping Q U I A
Overriding Q U I =

Example 3: Input data, 3 bytes, "ABC". Encoded output, 4 characters, "QUJD"
Input Data A B C
Input Bits 01000001 01000010 01000011
\ \ \
Bit Groups 010000 010100 001001 000011
Mapping Q U J D

[Patrizia]

It's been forever since I've messed with this, but just something else in my "junk drawer":

Option Explicit
'
Private Const Equals As Byte = 61     ' Asc("=")
'
Private Const Mask1 As Byte = 3       ' 00000011
Private Const Mask2 As Byte = 15      ' 00001111
Private Const Mask3 As Byte = 63      ' 00111111
Private Const Mask4 As Byte = 192     ' 11000000
Private Const Mask5 As Byte = 240     ' 11110000
Private Const Mask6 As Byte = 252     ' 11111100
'
Private Const Shift2 As Byte = 4
Private Const Shift4 As Byte = 16
Private Const Shift6 As Byte = 64
'
Private Base64Lookup() As Byte
Private Base64Reverse() As Byte
'

Public Function bFileExists(fle As String) As Boolean
    On Error GoTo FileExistsError
    ' If no error then something existed.
    bFileExists = (GetAttr(fle) And vbDirectory) = 0
    Exit Function
FileExistsError:
    bFileExists = False
    Exit Function
End Function

Public Property Let StringToAsciiFile(sFileSpec As String, sStr As String)
    ' If file exists, this will fail.
    Dim iFle As Long
    '
    If bFileExists(sFileSpec) Then Exit Property
    iFle = FreeFile
    On Error Resume Next
    Open sFileSpec For Output As iFle
    If Err <> 0 Then Close iFle: Exit Property
    On Error GoTo 0
    Print #iFle, sStr;
    Close iFle
End Property

Public Function AsciiFileToString(sFileSpec As String) As String
    Dim iFle As Long
    '
    If Not bFileExists(sFileSpec) Then Exit Function
    iFle = FreeFile
    On Error Resume Next
    Open sFileSpec For Binary As iFle
    If Err <> 0 Then Close iFle: Exit Function
    On Error GoTo 0
    If Len(iFle) = 0 Then Close iFle: Exit Function
    '
    ' For variable length strings, the number of bytes read equals the number of characters already in the string.
    AsciiFileToString = Space(LOF(iFle))
    Get iFle, 1, AsciiFileToString
    Close iFle
End Function

Public Function EncodeString(Text As String) As String
    Dim Data() As Byte
    '
    Initialize
    Data = StrConv(Text, vbFromUnicode)
    EncodeString = EncodeByteArray(Data)
End Function

Public Function EncodeByteArray(Data() As Byte) As String
    Dim EncodedData() As Byte
    Dim DataLength As Long
    Dim EncodedLength As Long
    Dim Data0 As Long
    Dim Data1 As Long
    Dim Data2 As Long
    Dim l As Long
    Dim m As Long
    Dim Index As Long
    Dim CharCount As Long
    '
    Initialize
    DataLength = UBound(Data) + 1
    '
    EncodedLength = (DataLength \ 3) * 4
    If DataLength Mod 3 > 0 Then EncodedLength = EncodedLength + 4
    EncodedLength = EncodedLength + ((EncodedLength \ 76) * 2)
    If EncodedLength Mod 78 = 0 Then EncodedLength = EncodedLength - 2
    ReDim EncodedData(EncodedLength - 1)
    '
    m = (DataLength) Mod 3
    '
    For l = 0 To UBound(Data) - m Step 3
        Data0 = Data(l)
        Data1 = Data(l + 1)
        Data2 = Data(l + 2)
        EncodedData(Index) = Base64Lookup(Data0 \ Shift2)
        EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
        EncodedData(Index + 2) = Base64Lookup(((Data1 And Mask2) * Shift2) Or (Data2 \ Shift6))
        EncodedData(Index + 3) = Base64Lookup(Data2 And Mask3)
        Index = Index + 4
        CharCount = CharCount + 4
        '
        If CharCount = 76 And Index < EncodedLength Then
            EncodedData(Index) = 13
            EncodedData(Index + 1) = 10
            CharCount = 0
            Index = Index + 2
        End If
    Next l
    '
    If m = 1 Then
        Data0 = Data(l)
        EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
        EncodedData(Index + 1) = Base64Lookup((Data0 And Mask1) * Shift4)
        EncodedData(Index + 2) = Equals
        EncodedData(Index + 3) = Equals
        Index = Index + 4
    ElseIf m = 2 Then
        Data0 = Data(l)
        Data1 = Data(l + 1)
        EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
        EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
        EncodedData(Index + 2) = Base64Lookup((Data1 And Mask2) * Shift2)
        EncodedData(Index + 3) = Equals
        Index = Index + 4
    End If
    '
    EncodeByteArray = StrConv(EncodedData, vbUnicode)
End Function

Public Function DecodeToString(EncodedText As String) As String
    Dim Data() As Byte
    '
    Initialize
    Data = DecodeToByteArray(EncodedText)
    DecodeToString = StrConv(Data, vbUnicode)
End Function

Public Function DecodeToByteArray(EncodedText As String) As Byte()
    Dim Data() As Byte
    Dim EncodedData() As Byte
    Dim DataLength As Long
    Dim EncodedLength As Long
    Dim EncodedData0 As Long
    Dim EncodedData1 As Long
    Dim EncodedData2 As Long
    Dim EncodedData3 As Long
    Dim l As Long
    Dim m As Long
    Dim Index As Long
    Dim CharCount As Long
    '
    Initialize
    ' Remove CRLF and "=" characters.
    EncodedData = StrConv(Replace$(Replace$(EncodedText, vbCrLf, ""), "=", ""), vbFromUnicode)
    '
    EncodedLength = UBound(EncodedData) + 1
    DataLength = (EncodedLength \ 4) * 3
    '
    m = EncodedLength Mod 4
    If m = 2 Then
        DataLength = DataLength + 1
    ElseIf m = 3 Then
        DataLength = DataLength + 2
    End If
    '
    ReDim Data(DataLength - 1)
    '
    For l = 0 To UBound(EncodedData) - m Step 4
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        EncodedData2 = Base64Reverse(EncodedData(l + 2))
        EncodedData3 = Base64Reverse(EncodedData(l + 3))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
        Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
        Data(Index + 2) = ((EncodedData2 And Mask1) * Shift6) Or EncodedData3
        Index = Index + 3
    Next l
    '
    Select Case ((UBound(EncodedData) + 1) Mod 4)
    Case 2
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
    Case 3
        EncodedData0 = Base64Reverse(EncodedData(l))
        EncodedData1 = Base64Reverse(EncodedData(l + 1))
        EncodedData2 = Base64Reverse(EncodedData(l + 2))
        Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
        Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
    End Select
    '
    DecodeToByteArray = Data
End Function

Private Sub Initialize()
    Dim l As Long
    Static bInitialized As Boolean
    '
    If bInitialized Then Exit Sub
    ReDim Base64Reverse(255)
    Base64Lookup = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
    For l = 0 To 63
        Base64Reverse(Base64Lookup(l)) = l
    Next l
    bInitialized = True
End Sub

p.s. The name of the module was Base64MimeCoding.bas.

Hi,
how can use the functions in the module?
I've .pdf file to encode in base64.

thank you
Patty

[wqweto]

Here is a not very fast but short solution with added utf-8 conversion as a bonus

Option Explicit

'--- for WideCharToMultiByte
Private Const CP_UTF8                       As Long = 65001

Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Public Function ToBase64(sValue As String, Optional ByVal MultiLine As Boolean) As String
    Dim baValue()       As Byte
    Dim lSize           As Long
    
    With VBA.CreateObject("MSXML2.DOMDocument").CreateElement("dummy")
        .DataType = "bin.base64"
        ReDim baValue(0 To 4 * Len(sValue))
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sValue), Len(sValue), baValue(0), UBound(baValue) + 1, 0, 0)
        If lSize > 0 Then
            ReDim Preserve baValue(0 To lSize - 1)
            .NodeTypedValue = baValue
        End If
        ToBase64 = .Text
        If Not MultiLine Then
            ToBase64 = Replace(Replace(ToBase64, vbCrLf, vbNullString), vbLf, vbNullString)
        End If
    End With
End Function

Public Function FromBase64(sBase64 As String) As String
    Dim baValue()       As Byte
    Dim sValue          As String
    Dim lSize           As Long
    
    With VBA.CreateObject("MSXML2.DOMDocument").CreateElement("dummy")
        .DataType = "bin.base64"
        .Text = sBase64
        baValue = .NodeTypedValue
        sValue = String$(4 * UBound(baValue), 0)
        lSize = MultiByteToWideChar(CP_UTF8, 0, baValue(0), UBound(baValue) + 1, StrPtr(sValue), Len(sValue))
        FromBase64 = Left$(sValue, lSize)
    End With
End Function

Private Sub Form_Load()
    MsgBox ToBase64("Lorem ipsum dolor sit amet, consectetur adipiscing elit. Curabitur facilisis consectetur massa, sit amet aliquam lacus cursus vel.")
End Sub

cheers,
</wqw>

[dilettante]

I'm not sure why we're gravedigging this old thread or answering VBA macro plinking questions in the VB programming forum, but...

If you install CAPICOM it becomes a trivial matter.

Despite the dire warnings they use to try to make you use .Net CAPICOM works fine.

Option Explicit

Private CAPIUtilities As New CAPICOM.Utilities

Private Sub Command1_Click()
    'Convert payload to ANSI, then Base64 encode that:
    Text2.Text = CAPIUtilities.Base64Encode(StrConv(Text1.Text, vbFromUnicode))
End Sub

Private Sub Command2_Click()
    'Decode Base64, convert payload back to Unicode:
    Text3.Text = StrConv(CAPIUtilities.Base64Decode(Text2.Text), vbUnicode)
End Sub