VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cBASE64" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cBASE64 Class Module ' -------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : January 04, 2003 ' Created On : January 20, 2003 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : NOTHING ' ' Description : This module is meant to make it easy to convert BINARY or STRING data to and from "BASE64" ' encoding. BASE64 is a method of encoding binary data within text. If you'll remember, ' binary data is a full 8 bits per byte, whereas text uses a little more than 6 bits per byte. ' A 6-bit number has 64 combinations, hence the term "BASE64". ' ' The way it works is that every three 8-bit bytes are stored in four 6-bit characters, where the ' characters are in the range [A-Z][a-z][0-9][+/]. (Count 'em up; that's 64 total characters). ' Since this doesn't exactly line up, padding characters of equal signs (=) are used on the end. ' ' NOTE : This code is based on code that was written by David Ireland in 2000, which was converted from ' C code originally written by Carl M. Ellison in 1995. ' ' Example Use : ' '------------------------------------------------------------------------------------------------------------- ' SAMPLE CODE - ENCODE BASE64 '------------------------------------------------------------------------------------------------------------- ' ' Option Explicit ' Private WithEvents objBASE64 As cBASE64 ' Private Sub Form_Load() ' Const INPUT_FILE_PATH As String = "C:\Original.bmp" ' Const OUTPUT_FILE_PATH As String = "C:\Base64.txt" ' Dim strInput As String ' Dim strReturn As String ' Dim intFileNum As Integer ' Me.Visible = True ' Me.Refresh ' Set objBASE64 = New cBASE64 ' ' Open a picture in text mode ' strInput = String(FileLen(INPUT_FILE_PATH), Chr(0)) ' Close ' Open INPUT_FILE_PATH For Binary Access Read As #1 ' Get #1, , strInput ' Close #1 ' If objBASE64.BASE64_Encode(strInput, strReturn) = True Then ' Open OUTPUT_FILE_PATH For Binary Access Write As #1 ' Put #1, , strReturn ' Close #1 ' End If ' Set objBASE64 = Nothing ' Unload Me ' End Sub ' Private Sub objBASE64_Progress(ByVal lngMin As Long, ByVal lngMax As Long, ByVal lngValue As Long) ' ProgressBar Picture1, lngMin, lngMax, lngValue, True, , , , , True ' Picture1.Refresh ' End Sub ' '------------------------------------------------------------------------------------------------------------- ' SAMPLE CODE - DECODE BASE64 '------------------------------------------------------------------------------------------------------------- ' ' Option Explicit ' Private WithEvents objBASE64 As cBASE64 ' Private Sub Form_Load() ' Const INPUT_FILE_PATH As String = "C:\Base64.txt" ' Const OUTPUT_FILE_PATH As String = "C:\Original.bmp" ' Dim strInput As String ' Dim strReturn As String ' Dim intFileNum As Integer ' Me.Visible = True ' Me.Refresh ' Set objBASE64 = New cBASE64 ' ' Open a picture in text mode ' strInput = String(FileLen(INPUT_FILE_PATH), Chr(0)) ' Close ' Open INPUT_FILE_PATH For Binary Access Read As #1 ' Get #1, , strInput ' Close #1 ' If objBASE64.BASE64_Decode(strInput, strReturn) = True Then ' Open OUTPUT_FILE_PATH For Binary Access Write As #1 ' Put #1, , strReturn ' Close #1 ' End If ' Set objBASE64 = Nothing ' Unload Me ' End Sub ' Private Sub objBASE64_Progress(ByVal lngMin As Long, ByVal lngMax As Long, ByVal lngValue As Long) ' ProgressBar Picture1, lngMin, lngMax, lngValue, True, , , , , True ' Picture1.Refresh ' End Sub ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' DO NOT ALTER THIS CONSTANT VALUE, OR NOTHING WILL WORK CORRECTLY Private Const BASE64_ENCODE_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ' Line width constant Private Const LINE_WIDTH As Integer = 60 ' Local variable that holds the decoding table Dim aintDecodingTable(255) As Integer ' Public event that tells the user the progress of the encoding process Public Event Progress(ByVal lngMin As Long, ByVal lngMax As Long, ByVal lngValue As Long) 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Private Sub Class_Initialize() Dim intCounter As Integer ' Set the default values of the decoding table to all (-1) For intCounter = 0 To 255 aintDecodingTable(intCounter) = -1 Next ' Create the decoding table to work with For intCounter = 1 To Len(BASE64_ENCODE_TABLE) aintDecodingTable(Asc(Mid(BASE64_ENCODE_TABLE, intCounter, 1))) = intCounter - 1 Next aintDecodingTable(Asc("=")) = 64 End Sub Private Sub Class_Terminate() ' Clean up the decoding table Erase aintDecodingTable End Sub 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX '============================================================================================================= ' BASE64_EncodeEx ' ' Description: ' ------------ ' This code takes the binary data passed to it and converts it to a BASE64 encoded string. ' ' Param Description ' --------------------------------- ' abytInput The binary information to convert to a BASE64 string ' Return_BASE64 If this function succeeds, this parameter returns the BASE64 encoded string ' ' Return: ' ------- ' Returns TRUE if the function executes successfully. Returns FALSE otherwise. ' '============================================================================================================= Public Function BASE64_EncodeEx(ByRef abytInput() As Byte, _ ByRef Return_BASE64 As String) As Boolean Dim strInput As String ' Set default return value Return_BASE64 = "" ' Validate parameters If UBound(abytInput) = -1 Then Exit Function ' Convert the byte array to a string strInput = abytInput ' Visual Basic strings (BSTR) are UNICODE... so convert it strInput = StrConv(strInput, vbUnicode) ' Call the main routine that converts the string to BASE64 BASE64_EncodeEx = BASE64_Encode(strInput, Return_BASE64) End Function '============================================================================================================= ' BASE64_Encode ' ' Description: ' ------------ ' This code takes the string data passed to it and converts it to a BASE64 encoded string. ' ' Param Description ' --------------------------------- ' strInput The string representation of the binary information to convert to a BASE64 string ' Return_BASE64 If this function succeeds, this parameter returns the BASE64 encoded string ' ' Return: ' ------- ' Returns TRUE if the function executes successfully. Returns FALSE otherwise. ' '============================================================================================================= Public Function BASE64_Encode(ByVal strInput As String, _ ByRef Return_BASE64 As String) As Boolean Dim strReturn As String Dim strLast As String Dim lngInputLength As Long Dim lngPosition As Long Dim lngCounter1 As Long Dim bytCounter2 As Byte Dim abytThree(2) As Byte Dim lngMax As Long ' Set the default return value Return_BASE64 = "" ' Get the length of the string to encode lngInputLength = Len(strInput) If lngInputLength < 1 Then Exit Function ' Read in 3 bytes of the input at a time lngMax = (lngInputLength \ 3) - 1 For lngCounter1 = 0 To lngMax For bytCounter2 = 0 To 2 abytThree(bytCounter2) = Asc(Mid(strInput, (lngCounter1 * 3) + bytCounter2 + 1, 1)) Next bytCounter2 strReturn = strReturn & QuantumEncode(abytThree) RaiseEvent Progress(0, lngMax, lngCounter1) Next lngCounter1 ' If the length isn't a multiple of 3, pad the ending to make it so Select Case lngInputLength Mod 3 Case 0 strLast = "" Case 1 abytThree(0) = Asc(Mid(strInput, lngInputLength, 1)) abytThree(1) = 0 abytThree(2) = 0 strLast = QuantumEncode(abytThree) strLast = Left(strLast, 2) & "==" ' Pad the end of the string with 2 x "=" Case 2 abytThree(0) = Asc(Mid(strInput, lngInputLength - 1, 1)) abytThree(1) = Asc(Mid(strInput, lngInputLength, 1)) abytThree(2) = 0 strLast = QuantumEncode(abytThree) strLast = Left(strLast, 3) & "=" ' Pad the end of the string with 1 x "=" End Select strReturn = strReturn & strLast ' Now that we have the properly encoded BASE64 string, we add CR + LF characters at the end of each ' line to make it easier to read and work with If Len(strReturn) < LINE_WIDTH Then Return_BASE64 = strReturn Else lngPosition = 1 lngInputLength = Len(strReturn) Do While lngPosition <= lngInputLength Return_BASE64 = Return_BASE64 & Mid(strReturn, lngPosition, LINE_WIDTH) & vbCrLf lngPosition = lngPosition + LINE_WIDTH Loop End If If Right(Return_BASE64, Len(vbCrLf)) = vbCrLf Then Return_BASE64 = Left(Return_BASE64, Len(Return_BASE64) - Len(vbCrLf)) ' Function succeeded BASE64_Encode = True End Function '============================================================================================================= ' BASE64_DecodeEx ' ' Description: ' ------------ ' This code takes the BASE64 encoded string data passed to it and converts it from BASE64 to it's original ' form. ' ' Note: ' ----- ' This function ignores all characters not in the 64 characters defined by the "BASE64_ENCODE_TABLE" constant ' ' Param Description ' -------------------------------------------------------- ' strBASE64_Encoded_String The BASE64 string to decode ' Return_BASE64 If this function succeeds, this parameter returns the result of decoding the ' BASE64 string in the form of a ZERO-BASED byte array. ' ' Return: ' ------- ' Returns TRUE if the function executes successfully. Returns FALSE otherwise. ' '============================================================================================================= Public Function BASE64_DecodeEx(ByVal strBASE64_Encoded_String As String, _ ByRef Return_Decoded() As Byte) As Boolean Dim strReturn As String ' Set default return value Erase Return_Decoded ' Validate parameters If Len(strBASE64_Encoded_String) < 1 Then Exit Function ' Decode the string BASE64_DecodeEx = BASE64_Decode(strBASE64_Encoded_String, strReturn) If BASE64_DecodeEx = True Then ' Convert the UNICODE VB String (BSTR) to a binary array (Byte Array) strReturn = StrConv(strReturn, vbFromUnicode) Return_Decoded = strReturn End If End Function '============================================================================================================= ' BASE64_Decode ' ' Description: ' ------------ ' This code takes the BASE64 encoded string data passed to it and converts it from BASE64 to it's original ' form. ' ' Note: ' ----- ' This function ignores all characters not in the 64 characters defined by the "BASE64_ENCODE_TABLE" constant ' ' Param Description ' -------------------------------------------------------- ' strBASE64_Encoded_String The BASE64 string to decode ' Return_BASE64 If this function succeeds, this parameter returns the result of decoding the ' BASE64 string in the form of a string. ' ' Return: ' ------- ' Returns TRUE if the function executes successfully. Returns FALSE otherwise. ' '============================================================================================================= Public Function BASE64_Decode(ByVal strBASE64_Encoded_String As String, _ ByRef Return_Decoded As String) As Boolean Dim bytDecodeByte(3) As Byte Dim strReturn As String Dim bytCurrentChar As Byte Dim intDecodeCount As Integer Dim lngCounter As Long Dim lngMax As Long ' Set the default return value Return_Decoded = "" ' Validate parameters If Len(strBASE64_Encoded_String) < 1 Then Exit Function ' Read in each char in trun lngMax = Len(strBASE64_Encoded_String) For lngCounter = 1 To lngMax bytCurrentChar = CByte(Asc(Mid(strBASE64_Encoded_String, lngCounter, 1))) If aintDecodingTable(bytCurrentChar) <> -1 Then bytCurrentChar = aintDecodingTable(bytCurrentChar) bytDecodeByte(intDecodeCount) = bytCurrentChar intDecodeCount = intDecodeCount + 1 If intDecodeCount = 4 Then strReturn = strReturn & QuantumDecode(bytDecodeByte) If bytDecodeByte(3) = 64 Then strReturn = Left(strReturn, Len(strReturn) - 1) End If If bytDecodeByte(2) = 64 Then strReturn = Left(strReturn, Len(strReturn) - 1) End If intDecodeCount = 0 End If End If RaiseEvent Progress(1, lngMax, lngCounter) Next lngCounter ' Return the resulting decoded string Return_Decoded = strReturn ' Function succeeded BASE64_Decode = True End Function 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' Shifts the bits of the passed value to the LEFT the specified number of times (i.e. - bytValue << bytShiftCount) Private Function BitShift_LEFT(ByVal bytValue As Byte, ByVal bytShiftCount As Byte) As Byte Dim bytCounter As Byte Dim bytReturn As Byte bytReturn = bytValue For bytCounter = 1 To bytShiftCount bytReturn = (bytReturn And &H7F) * 2 Next BitShift_LEFT = bytReturn End Function ' Shifts the bits of the passed value to the RIGHT the specified number of times (i.e. - bytValue >> bytShiftCount) Private Function BitShift_RIGHT(ByVal bytValue As Byte, ByVal bytShiftCount As Byte) As Byte Dim bytCounter As Byte Dim bytReturn As Byte bytReturn = bytValue For bytCounter = 1 To bytShiftCount bytReturn = (bytReturn \ 2) Next BitShift_RIGHT = bytReturn End Function Private Function QuantumEncode(ByRef bytArray() As Byte) As String Dim strReturn As String Dim lngCurrentChar As Long lngCurrentChar = BitShift_RIGHT(bytArray(0), 2) And &H3F strReturn = strReturn & Mid(BASE64_ENCODE_TABLE, lngCurrentChar + 1, 1) lngCurrentChar = BitShift_LEFT(bytArray(0) And &H3, 4) Or (BitShift_RIGHT(bytArray(1), 4) And &HF) strReturn = strReturn & Mid(BASE64_ENCODE_TABLE, lngCurrentChar + 1, 1) lngCurrentChar = BitShift_LEFT(bytArray(1) And &HF, 2) Or (BitShift_RIGHT(bytArray(2), 6) And &H3) strReturn = strReturn & Mid(BASE64_ENCODE_TABLE, lngCurrentChar + 1, 1) lngCurrentChar = bytArray(2) And &H3F strReturn = strReturn & Mid(BASE64_ENCODE_TABLE, lngCurrentChar + 1, 1) ' Return the result QuantumEncode = strReturn End Function Private Function QuantumDecode(ByRef bytArray() As Byte) As String Dim strReturn As String Dim lngCurrentChar As Long lngCurrentChar = BitShift_LEFT(bytArray(0), 2) Or (BitShift_RIGHT(bytArray(1), 4) And &H3) strReturn = strReturn & Chr(lngCurrentChar) lngCurrentChar = BitShift_LEFT(bytArray(1) And &HF, 4) Or (BitShift_RIGHT(bytArray(2), 2) And &HF) strReturn = strReturn & Chr(lngCurrentChar) lngCurrentChar = BitShift_LEFT(bytArray(2) And &H3, 6) Or bytArray(3) strReturn = strReturn & Chr(lngCurrentChar) ' Return the result QuantumDecode = strReturn End Function