Printable View
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
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.
It's been forever since I've messed with this, but just something else in my "junk drawer":
p.s. The name of the module was Base64MimeCoding.bas.Code: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
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
Hi,Quote:
Originally Posted by Elroy
how can use the functions in the module?
I've .pdf file to encode in base64.
thank you
Patty
Here is a not very fast but short solution with added utf-8 conversion as a bonus
cheers,Code: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
</wqw>
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.
Code: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