base256 | : cyclone : binary-to-emoji encoding | Icon library

Attribute VB_Name = "base2_6"
''Total hack- BUT it works to jam 21 characters using a 6 bit reference
''into a 128bit GUID
''Characters register 6 bit binary MSB at left,
''every 8 bits gets jammed into a HEX and those bits removed off the stack
''when max characters is reached- there are 2 bits left over - filled with
''LSB "00" to force the HEX to generate for 32 characters of hex for
''A 128 bit GUID. Will work on the round trip next to convert from GUID
''to string - 5 more characters than a straight ASCII to hex conversion

Option Explicit
''Background - to create as long of a static GUID from a string (21)
''Base 2^6 = 6 bit, 64 characters, # 0-63
''decode = Value - (CharPosition*Base)
''Encode = Value + (CharPosition*Base)

'look at 24 bit chunks (6bit and 8bit share every 24 bits bit group.)
'00000x00000x00000x00000x       = every four characters in 6 bit = 24 bits
'0000000x0000000x0000000x       = 3 bytes
'-2hex--x-2hex--x-2hex--x       = 3 hex bytes per 4 characters
'128bit = 16 hex pairs or 21 characters + 2 leftover bits.
Const vbqt = """"
''Full VISUAL ASCII characters from 32(space) through 126 ~
Const strASC = " !" & vbqt & "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
''Revit illegal chars "Filesystem"                   :;< >?                           [\]  `                          {|}
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''5 bit - would allow for 25 charqacters simplified- ignoring upper and lower case
''would require a UCASE convert prior to checking. can contain a few digits only
''Optional simpler base 5bit- not used - do not change this - it will change the whole field base and compression!
''do not change this - it will change the whole field base and compression!
''''''''''''''''0''''''''1'''''''''2'''''''''3'*<31 MAX (32 CHARS)
''''''''''''''''01234567890123456789012345678901 ''NoSpaces!
Const Base5b = ".0123ABCDEFGHIJKLMNOPQRSTUVWXYZ_"
Const x5b = 5   ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''6 bit - allows for 21 charqacters simplified- ignoring upper and lower case
''do not change this - it will change the whole field base and compression!
''''''''''''''''00''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6''''
''''''''''''''''0123456789012345678901234567890123456789012345678901234567890123  ''NoSpaces!
Const Base6b = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
Const x6b = 6   ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''7 bit - would only allow for 18 characters
''do not change this - it will change the whole field base and compression!
''''''''''''''''00           ''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''''12      *<127
''''''''''''''''01    2       34567890123456789012345678901234567890123456789012345678901234567890123456789---01234567
Const Base7b = " !" & vbqt & "#$%&'()*+.123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
Const x7b = 7   ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''8 bit - allows for 256 characters
''Same as straight hex encoding xFF 256 bits - mostly 173 wasted spaces
''''''''''''''''0------------''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''
''''''''''''''''0----1-------2345678901234567890123456789012345678901234567890123456789012345678901234567890123
Const Base8b = "!" & vbqt & "#$%&'()*+,-./0123456789:;=@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz"

Function Encode6Bit2HexGUID(VarName As String) As String ''Range) As String ''guid in HEX
''takes a string of fixed characters Base6b compared against 6 bits to compress 4 characters for every 3 Bytes (FFFFFF)
''To pack into 128 bit string for GUID.
Dim i           As Integer          ''count integer
Dim ie          As Integer          ''iend of count either  MaxChar or less
Dim strName     As String           ''string to nibble
Dim HexStr      As String           ''Hex string to build
        
Const MaxChar = 21

Dim enc6b       As Long             ''6bit value per character
    
Dim binStr      As String           ''Binary representation of number
''strName = VarName.value  ''get value to work with
strName = VarName
    If Len(strName) > MaxChar Then
        MsgBox MaxChar & " character limite exceeded, variables must be unique within the first  MaxChar characters.", vbExclamation + vbOKOnly, "Warning"
        '
        ie = MaxChar
        strName = Left(strName, MaxChar)
    Else
        ie = Len(Left(strName, MaxChar)) '''''''''''''''''''<<<<<<<<<<<<<= 8
        HexStr = HexStr & Right("0" & Hex(Bin2Dec(Left(binStr, 8))), 2)
        binStr = Right(binStr, Len(binStr) - 8)
    Loop

Next i

Encode6Bit2HexGUID = Left(HexStr & String(32, "0"), 32)
'''''''''0            1              2              3
'''''''''12 34 56 78 90 12 34 56 78 90 12 34 56 78 90 12
''guid = XX.XX.XX.XX-XX.XX-XX.XX-XX.XX-XX.XX.XX.XX.XX.XX

''format GUID
Encode6Bit2HexGUID = Format(Encode6Bit2HexGUID, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&"))

End Function

Function enc6Bc(X As String) As Integer
    enc6Bc = InStr(1, Base6b, Left(X, 1), vbBinaryCompare) - 1
    If enc6Bc = -1 Then enc6Bc = 0            ''substitute 1st character if not found (returns 0)
End Function

Function Dec2Bina(X As Long, BitNo As Integer) As String
''RA: MAY TAKE A HEAVIER COMPUTATIONAL TOLL THAN THE DIVIDE/2 METHOD
Dim i
For i = BitNo - 1 To 0 Step -1
    If X >= 2^ ^ i Then
        X = X - 2^ ^ i
        Dec2Bina = Dec2Bina & "1"
    Else
        Dec2Bina = Dec2Bina & "0"
    End If
Next i
End Function

'Decimal To Binary
' =================
' Source: http://groups.google.ca/group/comp.lang.visual.basic/browse_thread/thread/28affecddaca98b4/979c5e918fad7e63
' Author: Randy Birch (MVP Visual Basic)
' NOTE: You can limit the size of the returned
'              answer by specifying the number of bits
Function Dec2Bin(ByVal DecimalIn As Variant, _
              Optional NumberOfBits As Variant) As String
    Dec2Bin = ""
    DecimalIn = Int(CDec(DecimalIn))
    Do While DecimalIn <> 0
        Dec2Bin = Format$(DecimalIn - 2 * Int(DecimalIn / 2)) & Dec2Bin
        DecimalIn = Int(DecimalIn / 2)  ''SHIFT ONE BIT TO THE LEFT WITH DIV2
    Loop
    If Not IsMissing(NumberOfBits) Then
       If Len(Dec2Bin) > NumberOfBits Then
          Dec2Bin = "Error - Number exceeds specified bit size"
       Else
          Dec2Bin = Right$(String$(NumberOfBits, _
                    "0") & Dec2Bin, NumberOfBits)
       End If
    End If
End Function

'Binary To Decimal
' =================
Function Bin2Dec(BinaryString As String) As Variant
    Dim X As Integer
    For X = 0 To Len(BinaryString) - 1
        Bin2Dec = CDec(Bin2Dec) + Val(Mid(BinaryString, _
                  Len(BinaryString) - X, 1)) * 2 ^ X
    Next
End Function

Public Function String_from_6Bit2HexGUID(strGUID As String) As String
Dim i           As Integer
Dim strBin      As String
Dim str3byte    As String
Dim Long3Byte   As Long
Dim strVarName  As String
    strGUID = Replace(strGUID, "-", "") ''remove the dashes
    For i = 1 To Len(strGUID) Step 6
        str3byte = Left(strGUID, 6)
        strGUID = Right(strGUID, Len(strGUID) - Len(str3byte))
        Long3Byte = CLng("&H" & str3byte)
        If i = 31 Then
            strBin = Left(Dec2Bin(Long3Byte, 8), 6)
        Else
            strBin = Dec2Bin(Long3Byte, 24)
        End If
        Do While strBin > ""
           strVarName = strVarName & Mid(Base6b, Bin2Dec(Left(strBin, 6)) + 1, 1)
           strBin = Right(strBin, Len(strBin) - 6)
        Loop
    Next i
    String_from_6Bit2HexGUID = strVarName
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Testing funcitons for in and back
Private Sub test_Encode6Bit2Hex()
''''''''''''''''''''''''''''''''0        1         2
                               '123456789012345687901