CODAGE EN BASE 64

'************************************************************************'
'************************************************************************'
'**                                                                    **'
'**                       BASE 64 CODING MODULE                        **'
'**                                                                    **'
'************************************************************************'
'************************************************************************'



'----------------------------   PROPERTIES   ----------------------------'
'Author = Santiago Diez
'Date = 22 JUNE 2006  17:37
'Version = 1.0
'---------------------------   DESCRIPTION   ----------------------------'
'Provide procedures to code and decode using "base64". This 64 characters-
'based code is  mainly used for  transfering  files throught  e-mail as it
'only uses non-ambigues  character in  regard to international  alphabets,
'wich means using only latin characters (without accents), numbers and the
'characters plus ("+") and slash ("/").
'---------------------------   HOW IT WORKS   ---------------------------'
'26 capitals + 26 letters + 10 digits + plus + slash = 64 characters
'6 bits are necessary to code each base64 characters (2 ^ 6 = 64).
'(1 - ENCODING) A file is viewed as a stream of bytes (8 bits). Each group
'of 3 bytes makes 24 bits that actually  makes 4 base64 characters. At the
'end of the file, it may remain 1 or 2 bytes (8 or 16 bits).
'8 bits  are  completed  with 4  zeros,  wich makes  12  bits or  2 base64
'characters. Then  the 2 characters  are  completed to 4  using the base64
'feeding character ("=").
'16 bits  are  completed with  2 zeros,  wich  makes 18  bits or  3 base64
'characters that are completed to 4 with one feeding character ("=").
'A carriage return–linefeed  combination  is added every  76 characters to
'reach e-mail rules.
'(2 - DECODING)  Each  group of  4 base64  characters  makes 24  bits or 3
'bytes. At the end of the base64 stream,  it may remain 2 or 3 characters:
'feeding  characters  ("=")  are ignored  and 1  character  is  impossible
'following encoding rules.
'2 characters makes 12 bits, rounded down to 8 wich makes 1 byte.
'3 characters makes 18 bits, rounded down to 16 wich makes 2 bytes.
'-----------------   PUBLIC PROCEDURES AND FUNCTIONS   ------------------'
'B64Encode(HexStream, OutputStream, [BinRem = ""], [StrMultipleLen As Long
'                                            = 4], [LineLen As Long = 76])
'B64Decode(B64Stream, OutputStream, [BinRem = ""], [OverWrite As Boolean
'                                                                = False])
'-----------------------------   EXAMPLES   -----------------------------'
'To code a file to a string variable:
'Dim Base64Stream, MyFile
'MyFile = "C:\WINDOWS\NOTEPAD.EXE"
'Call B64Encode(MyFile, Base64Stream)
'If IsNull(Base64Stream) Then
'    MsgBox "Error: could not code file."
'Else
'    MsgBox "Print Base64Stream in a mail."
'End If
'To decode a string variable to a file:
'Dim Base64Stream, MyFile
'Base64Stream = "///+AAya6A/ff+AAAA=="
'MyFile = "C:\File.dat"
'Call B64Decode(Base64Stream, MyFile)
'If IsNull(MyFile) Then
'    MsgBox "Error: could not decode Base64Stream."
'Else
'    MsgBox "Base64Stream was succesfuly saved in " & MyFile & "."
'End If
'To code a hexadecimal string to a string variable:
'Dim Base64Stream, HexString, BinaryRemainder
'HexString = "A51DEA7611455AD"
'BinaryRemainder = ""
'Call B64Encode(HexString, Base64Stream, BinaryRemainder)
'If IsNull(Base64Stream) Then
'    MsgBox "Error: HexString is not hexadecimal."
'Else
'    MsgBox "Base64Stream contains the base64 code." & vbCrLf & _
'           "BinaryRemainder contains the remaining bits."
'End If
'-------------------------------   BUGS   -------------------------------'
'No bug reported.
'-----------------------------   SOURCES   ------------------------------'
'None
'-----------------------------   SEE ALSO   -----------------------------'
'None
'------------------------   REQUIRED LIBRARIES   ------------------------'
'msvbvm60.dll            VB6.OLB                 VB6FR.DLL
'--------------------   REQUIRED MODULES AND FORMS   --------------------'
'None
'-----------------------------   OPTIONS   ------------------------------'
Option Base 1
Option Compare Text
Option Explicit



'+----------------------------------------------------------------------+'
'+                           GLOBAL VARIABLES                           +'
'+----------------------------------------------------------------------+'
Private Const BASE64_CHARSET As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZa" & _
                                "bcdefghijklmnopqrstuvwxyz0123456789+/"
Private Const BASE64_BINSET As String = "000000:000001:000010:000011:" & _
    "000100:000101:000110:000111:001000:001001:001010:001011:001100:0" & _
    "01101:001110:001111:010000:010001:010010:010011:010100:010101:01" & _
    "0110:010111:011000:011001:011010:011011:011100:011101:011110:011" & _
    "111:100000:100001:100010:100011:100100:100101:100110:100111:1010" & _
    "00:101001:101010:101011:101100:101101:101110:101111:110000:11000" & _
    "1:110010:110011:110100:110101:110110:110111:111000:111001:111010" & _
    ":111011:111100:111101:111110:111111:"
Private Const BASE64_BINSEP As String = ":"
Private Const BASE64_BINLEN As Long = 6
Private Const BASE64_FEED As String = "="

Private Const BASE16_CHARSET As String = "0123456789ABCDEF"
Private Const BASE16_BINSET As String = "0000:0001:0010:0011:0100:010" & _
    "1:0110:0111:1000:1001:1010:1011:1100:1101:1110:1111:"
Private Const BASE16_BINSEP As String = ":"
Private Const BASE16_BINLEN As Long = 4



'+----------------------------------------------------------------------+'
'+                               ENCODING                               +'
'+----------------------------------------------------------------------+'
'"B64Encode" is a  procedure that codes  an hexadecimal  stream (string or
'file specification) into a base64 stream (string).
'"HexStream" is the hexadecimal stream to be coded (string or file).
'"OutputStream"  is a  variable (string)  passed  by reference  in wich is
'stored the base64 stream corresponding to "HexStream".
'"BinRem" is a variable  (string)  passed by reference  that may input the
'binary remainder of any previous  coding operation and is returned as the
'binary remainder of this coding operation.
'"StrMultipleLen"  fixes the  length  of "OutputStream"  as a  multiple of
'"StrMultipleLen". If it is greater  than zero, "BinRem" is completed with
'zeros to be converted into  a base64 string and  added to "OutputStream".
'"OutputStream" is  completed with  the base64 feeding  character to reach
'the nearest multiple  length. "BinRem" is set to  the zero-length strings
'(""). Default value is 4 as stated in the base64 nomenclature.
'"LineLen"  fixes the  length of  the lines  in  "OutputStream".  If it is
'greater  than   zero,  "B64Encode"   adds  a   carriage   return–linefeed
'combination every "LineLen" characters.  Default value is 76 as stated in
'the base64 nomenclature.
'If  "HexStream"   and  "BinRem"  are   both  zero-length   strings  (""),
'"OutputStream" is set to the zero-length string ("").
'If "HexStream" is Null or not  hexadecimal and cannot be interpreted as a
'file address, "OutputStream" is set to Null.
'If "BinRem" is Null or not binary, "OutputStream" is set to Null.
'If "StrMultipleLen" is less than zero, it is considered as zero.
'If "LineLen" is less than zero, it is considered as zero.
'Difference between (1) "StrMultipleLen" = 0 and (2) "StrMultipleLen" = 1:
'(1) if there is a binary remainder, it is returned through "BinRem"
'(2) if there is  a binary remainder,  it is feeded with  zeros to make it
'codable into a base64 character (then "BinRem" = "").
Sub B64Encode(HexStream, OutputStream, Optional binrem = "", Optional _
StrMultipleLen As Long = 4, Optional LineLen As Long = 76)
    Dim i As Long, j As Long
    Dim StrLen As Long
    Dim BinRemBackup
    BinRemBackup = binrem
    On Error GoTo BaseErr
    'Try to open "HexStream" as a file
    Call OpenFileInHex(HexStream)
    'Case "HexStream" = "" and "BinRem" = ""
    If CStr(HexStream) & CStr(binrem) = "" _
    Then OutputStream = "": Exit Sub
    'Calculate "BinRem" length,  rounding up to the  first "BASE64_BINLEN"
    'multiple (if "StrMultipleLen" > 0)
    StrLen = Len(binrem) + BASE16_BINLEN * Len(HexStream)
    If StrMultipleLen > 0 _
    Then StrLen = -Int(-StrLen / BASE64_BINLEN) * BASE64_BINLEN
    'Initialize "BinRem"
    binrem = String$(StrLen, "0")
    Mid$(binrem, 1) = BinRemBackup
    'Build binary stream from remainder and hexadecimal stream
    j = Len(BinRemBackup) + 1
    For i = 1 To Len(HexStream)
        Mid$(binrem, j) = CStr(B16Bin(Mid$(HexStream, i, 1)))
        j = j + BASE16_BINLEN
    Next
    'Calculate   "OutputStream"   length,   rounding   up  to  the   first
    '"StrMultipleLen" multiple
    StrLen = Int(Len(binrem) / BASE64_BINLEN)
    If StrMultipleLen > 1 _
    Then StrLen = -Int(-StrLen / StrMultipleLen) * StrMultipleLen
    'Split function in two depending on "LineLen" value
    j = 1
    If LineLen > 0 Then
        StrLen = StrLen + 2 * Int((StrLen - 1) / LineLen)
        'Initialize "OutputStream"
        OutputStream = String$(StrLen, BASE64_FEED)
        For i = LineLen + 1 To Len(OutputStream) Step LineLen + 2
            Mid$(OutputStream, i) = vbCrLf
        Next
        'Build base64 stream from binary stream (except last character)
        For i = 1 To Len(binrem) - BASE64_BINLEN Step BASE64_BINLEN
            Mid$(OutputStream, j _
                ) = CStr(B64Chr(Mid$(binrem, i, BASE64_BINLEN)))
            j = j + 1 - 2 * ((j + 2) Mod (LineLen + 2) = 0)
        Next
    Else
        'Initialize "OutputStream"
        OutputStream = String$(StrLen, BASE64_FEED)
        'Build base64 stream from binary stream (except last character)
        For i = 1 To Len(binrem) - BASE64_BINLEN Step BASE64_BINLEN
            Mid$(OutputStream, j _
                ) = CStr(B64Chr(Mid$(binrem, i, BASE64_BINLEN)))
            j = j + 1
        Next
    End If
    'Add last base64 character (if "StrMultipleLen" > 0) and set "BinRem"
    If StrMultipleLen > 0 Then
        Mid$(OutputStream, j _
            ) = CStr(B64Chr(Mid$(binrem, i, BASE64_BINLEN)))
        binrem = ""
    Else
        binrem = Mid$(binrem, i)
    End If
Exit Sub
BaseErr:
    binrem = BinRemBackup
    OutputStream = Null
End Sub



'+----------------------------------------------------------------------+'
'+                               DECODING                               +'
'+----------------------------------------------------------------------+'
'"B64Decode" is a procedure that decodes a base64 stream (string) into an
'hexadecimal stream (string or file specification).
'"B64Stream" is the hexadecimal stream (string) to be decoded.
'"Outputstream"  is a variable  (string) passed  by reference.  If it is a
'string expression  that specifies a  file name (may  include directory or
'folder, and  drive),  "B64Stream"  will be decoded  to the  corresponding
'file. If not, the resulting hexadecimal stream will be stored in variable
'"OutputStream".
'"OverWrite" specifies if "OutputStream" file can be overwritten or not.
'"BinRem" is a variable  (string)  passed by reference  that may input the
'binary remainder of any previous  coding operation and is returned as the
'binary remainder of this coding operation.
'If  "B64Stream"   and  "BinRem"  are   both  zero-length   strings  (""),
'"OutputStream"  is set to the  zero-length  string ("") or  the specified
'file is saved as a blank file (0 kb).
'If "B64tream" Is Null Or Not base64², "OutputStream" is set to Null¹.
'If "BinRem" is Null or not binary, "OutputStream" is set to Null¹.
'If "OverWrite"  is  False  and the  file  specified  with  "OutputStream"
'already exists, "OutputStream" is set to Null¹.
' ¹ It means that  even if you  want the output  to be a  file, you should
'always call the procedure giving  "OutputStream" a variable rather than a
'constant or string  expression. So that you can  read that variable after
'"B64Encode" and check for errors.
' ² Carriage return  and Line feed  characters are  ignored but the base64
'feeding character ("=") causes an error.
Sub B64Decode(B64Stream, OutputStream, Optional binrem = "", Optional _
OverWrite As Boolean = False)
    Dim i As Long, j As Long
    Dim StrLen As Long
    Dim BinRemBackup, OutputStreamBackup
    BinRemBackup = binrem
    OutputStreamBackup = OutputStream
    On Error GoTo BaseErr
    'Case "B64Stream" = "" and "BinRem" = ""
    If CStr(B64Stream) & CStr(binrem) = "" _
    Then OutputStream = "": GoTo MakeFile
    'Ignore base64 feeding characters ("=") at the end of the stream ¹
    StrLen = Len(B64Stream)
    Do While Mid$(B64Stream, StrLen, 1) = BASE64_FEED
        StrLen = StrLen - 1
    Loop
    'Initialize "BinRem" ¹
    binrem = String$(Len(binrem) + BASE64_BINLEN * StrLen, "0")
    Mid$(binrem, 1) = BinRemBackup
    'Build binary stream from remainder and base64 stream ¹
    j = Len(BinRemBackup) + 1
    For i = 1 To StrLen
        Select Case Mid$(B64Stream, i, 1)
            Case vbCr, vbLf
            Case Else
                Mid$(binrem, j) = CStr(B64Bin(Mid$(B64Stream, i, 1)))
                j = j + BASE64_BINLEN
        End Select
    Next
    '"BinRem" may have been initialized  longer than necessary if decoding
    'encounters carriage return and/or linefeed characters ¹
    binrem = Left$(binrem, j - 1)
    'Calculate "OutputStream" length,  rounding DOWN to the first multiple
    'of 8 (two hexadecimal characters)
    StrLen = 2 * Int(Len(binrem) / BASE16_BINLEN / 2)
    'Initialize "OutputStream"
    OutputStream = String$(StrLen, "0")
    'Build hexadecimal stream from binary stream
    j = 1
    For i = 1 To StrLen
        Mid$(OutputStream, i _
            ) = CStr(B16Chr(Mid$(binrem, j, BASE16_BINLEN)))
        j = j + BASE16_BINLEN
    Next
    'Set "BinRem"
    If Right$(B64Stream, 1) = BASE64_FEED _
    Then binrem = "" _
    Else binrem = Mid$(binrem, j)
MakeFile:
    Call SaveFileAsHex(OutputStream, OutputStreamBackup, OverWrite)
Exit Sub
BaseErr:
    binrem = BinRemBackup
    OutputStream = Null
    ' ¹ I avoid  as much as  possible to set  string variable  with string
    'operations  like  "String = Replace()" or  "String = String & String"
    'because such operations rewrite entirely the string wich is very time
    'consuming specially with long streams.
End Sub



'+----------------------------------------------------------------------+'
'+                    HEXADECIMAL TO BINARY FUNCTION                    +'
'+----------------------------------------------------------------------+'
'Returns the  binary code  of the  first character  of hexadecimal  string
'"HexString".
'If "HexString" is a zero-length string (""), B16Bin returns a zero-length
'string ("").
'If "HexString" is Null or its first character is not hexadecimal, Null is
'returned.
Private Function B16Bin(HexString)
    On Error GoTo ErrBase
    If HexString = "" _
    Then B16Bin = "" _
    Else B16Bin = Mid$(BASE16_BINSET, (BASE16_BINLEN + 1) _
                  * InStr(BASE16_CHARSET, Left$(HexString _
                  , 1)) - BASE16_BINLEN, BASE16_BINLEN)
    Exit Function
'HexString is not a hexadecimal digit.
ErrBase:
    B16Bin = Null
End Function
'+----------------------------------------------------------------------+'
'+                      BASE64 TO BINARY FUNCTION                       +'
'+----------------------------------------------------------------------+'
'Returns  the  binary  code  of  the  first  character  of  base64  string
'"B64String".
'If "B64String" is a zero-length string (""), B64Bin returns a zero-length
'string ("").
'If "B64String"  is Null or  its first  character is  not base64,  Null is
'returned.
Private Function B64Bin(B64String)
    On Error GoTo ErrBase
    If B64String = "" Then B64Bin = "" _
    Else B64Bin = Mid$(BASE64_BINSET, (BASE64_BINLEN + 1) * InStr(1, _
                  BASE64_CHARSET, Left(B64String, 1), vbBinaryCompare) _
                  - BASE64_BINLEN, BASE64_BINLEN)
    Exit Function
ErrBase:
    B64Bin = Null
End Function
'+----------------------------------------------------------------------+'
'+                    BINARY TO HEXADECIMAL FUNCTION                    +'
'+----------------------------------------------------------------------+'
'Returns the hexadecimal character  of the first 4 digits of binary string
'"BinString".
'If "BinString" is a zero-length string (""), B16Chr returns a zero-length
'string ("").
'If "BinString" is Null or its length is less than 4 or its first 4 digits
'are not binary, Null is returned.
Private Function B16Chr(BinString)
    On Error GoTo ErrBase
    If BinString = "" Then B16Chr = "": Exit Function
    If Len(CStr(BinString)) < BASE16_BINLEN Then GoTo ErrBase
    B16Chr = Mid$(BASE16_CHARSET, Int((InStr(1, BASE16_BINSET, Left$( _
             BinString, BASE16_BINLEN) & BASE16_BINSEP, vbBinaryCompare) _
             + BASE16_BINLEN) / (BASE16_BINLEN + 1)), 1)
    Exit Function
'BinString is not a binary string.
ErrBase:
    B16Chr = Null
End Function
'+----------------------------------------------------------------------+'
'+                      BINARY TO BASE64 FUNCTION                       +'
'+----------------------------------------------------------------------+'
'Returns  the base64  character  of the first  6 digits  of binary  string
'"BinString".
'If "BinString" is a zero-length string (""), B64Chr returns a zero-length
'string ("").
'If "BinString" is Null or its length is less than 6 or its first 6 digits
'are not binary, Null is returned.
Private Function B64Chr(BinString)
    On Error GoTo ErrBase
    If BinString = "" Then B64Chr = "": Exit Function
    If Len(CStr(BinString)) < BASE64_BINLEN Then GoTo ErrBase
    B64Chr = Mid$(BASE64_CHARSET, Int((InStr(1, BASE64_BINSET, Left$( _
             BinString, BASE64_BINLEN) & BASE64_BINSEP, vbBinaryCompare) _
             + BASE64_BINLEN) / (BASE64_BINLEN + 1)), 1)
    Exit Function
'BinString is not a binary string.
ErrBase:
    B64Chr = Null
End Function



'+----------------------------------------------------------------------+'
'+                  OPEN FILE IN HEXADECIMAL PROCEDURE                  +'
'+----------------------------------------------------------------------+'
'Try to transform a  path to a specific  file (absolute  or relative) into
'the corresponding file hexadecimal stream.
'If "HexStream"  is a string  expression that  specifies a  file name (may
'include  directory  or   folder,  and  drive),   the  corresponding  file
'hexadecimal  stream  is  read  and   stored  into  "HexStream".  If  not,
'"HexStream" remains unchanged.
Private Sub OpenFileInHex(HexStream)
    Dim i As Long
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim FileId As Long
    Dim Buffer As Byte
    Dim BufLen As Long
    'Check existence of file specified with "HexStream"
    If Not FSO.FileExists(HexStream) Then GoTo NotFile
    'Try to open file "HexStream" in binary mode
    On Error GoTo ReadErr
    FileId = FreeFile
    BufLen = Len(Buffer)
    Open HexStream For Random As FileId Len = BufLen
    HexStream = String$(2 * BufLen * LOF(FileId), "0")
    For i = 1 To LOF(FileId)
        Get FileId, i, Buffer
        If Buffer < 16 _
        Then Mid$(HexStream, (i - 1) * 2 * BufLen + 2 _
        ) = Hex(Buffer) Else Mid$(HexStream, (i - 1) * 2 * BufLen + 1) = Hex(Buffer)
    Next
    Close FileId
Exit Sub
NotFile:
ReadErr:
End Sub
'+----------------------------------------------------------------------+'
'+              SAVE FILE AS HEXADECIMAL STREAM PROCEDURE               +'
'+----------------------------------------------------------------------+'
'Save a hexadecimal stream (string) to a file.
'"OutputStream" is the hexadecimal stream (string).
'"FileSpec" may  be a string  expression that  specifies a  file name (may
'include directory or folder, and drive).
'"OverWrite" specifies if the file can be overwritten or not.
'If "OutputStream" is Null, no file is created nor modified.
'If "OutputStream" is a  zero-length strings (""),  a blank file (0 kb) is
'created.
'If "OutputStream"  is not  hexadecimal,  it is  set to Null  and the file
'created will probably be corrupted.
'If  "FileSpec"  is  a  string expression  that  specifies  a  file  name,
'"OutputStream"  is  used  to  create  such  a  file  and is  then  set to
'"FileSpec". If not, every variables remain unchanged.
Private Sub SaveFileAsHex(OutputStream, FileSpec, OverWrite As Boolean)
    Dim i As Long
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim FileId As Long
    Dim Buffer As Byte
    Dim BufLen As Long
    'Check existence of file specified with "FileSpec"
    If FSO.FileExists(FileSpec) And Not OverWrite Then GoTo FileExists
    'Open file "FileSpec" in output mode (empty file)
    On Error GoTo NotFile
    FileId = FreeFile
    Open FileSpec For Output As FileId
    Close FileId
    'Open file "FileSpec" in binary mode
    On Error GoTo SaveErr
    BufLen = Len(Buffer)
    Open FileSpec For Random As FileId Len = BufLen
    For i = 1 To Len(OutputStream) Step 2
        Put FileId, (i - 1) / 2 + 1, CByte("&H" & Mid$(OutputStream, i, 2))
    Next
    Close FileId
    'Reset "OutputStream" to its original value
    OutputStream = FileSpec
Exit Sub
SaveErr:
FileExists:
    OutputStream = Null
NotFile:
End Sub

Télécharger le zip