Encode string using 6-bir 64 character string to GUID and back check

Attribute VB_Name = "CharEncode" ''2020-08-30-shared with KTGY provided credit is provided for original works. ''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 = ".1234ABCDEFGHIJKLMNOPQRSTUVWXYZ_" Const x5b = 5 ''Encoding bitsize ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''6 bit - allows for 21 charqacters simplified- CASE matters in revit parameters foo is different from FOO ''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 Range) 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. Const BITc As Integer = 6 ''bitcount 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 As Integer = 128 / BITc - 0.5 ''128 bit GUID / bit count rounded down for INT Dim encB As Long ''bit value per character Dim binStr As String ''Binary representation of number ''strName = VarName.value ''get value to work with strName = Trim(VarName.value) If Len(strName) > MaxChar Then 'MsgBox MaxChar & " character limite exceeded, variables must be unique within the first MaxChar characters.", vbExclamation + vbOKOnly, "Warning" ' VarName.ClearComments VarName.AddCommentThreaded ("Warning, Check for duplicates" & MaxChar & " character maximim Exceeded.") Evaluate ("RangeWarn_Set(" & VarName.Address(False, False) & ")") ie = MaxChar strName = Left(strName, MaxChar) Else Evaluate ("RangeWarn_clear(" & VarName.Address(False, False) & ")") ie = Len(Left(strName, MaxChar)) '''''''''''''''''''<<<<<<<<<<<<<<DEBUG test 'If ie < 4 Then ie = 4 ''need every 4 characters to make up 3 hex pairs ie = Round((ie / 4) + 0.5, 0) * 4 End If For i = 1 To ie ''loop thorugh string name encB = enc6Bc(Mid(strName, i, 1)) ''Get char position in matrix binStr = binStr & Dec2Bin(encB, x6b) ''ENCODE 6 BIT BINARY If i = MaxChar Then binStr = binStr & String(Len(binStr) Mod 8, "0") ''force last remainder bits to fill out to 8 bit chunk for hex End If ''check if 8 or more binaries to byte into a hex Do While Len(binStr) >= 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 Const BITc As Integer = 6 ''bitcount 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 Public Function String_from_5Bit2HexGUID(strGUID As String) As String Const BITc As Integer = 5 ''bitcount 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 2 ''2 hex pairs each to convert to BIN string str3byte = Left(strGUID, 2) ''first 6 hex pairs strGUID = Right(strGUID, Len(strGUID) - Len(str3byte)) ''strip remaining hex pairs Long3Byte = CLng("&H" & str3byte) ''convert to LONG type strBin = strBin & Dec2Bin(Long3Byte, 8) ''Hex FF to BIN Next i Do While strBin > "" And Len(strBin) > BITc strVarName = strVarName & Mid(Base5b, Bin2Dec(Left(strBin, BITc)) + 1, 1) ''get character based on bits If Len(strBin) > BITc Then strBin = Right(strBin, Len(strBin) - BITc) Loop String_from_5Bit2HexGUID = strVarName End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub printASCII() Dim i Dim str For i = 32 To 126 str = str & Chr(i) Next i Debug.Print str End Sub Function Encode5Bit2HexGUID(VarName As Range) 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. Const BITc As Integer = 5 ''bitcount 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 As Integer = (128 / BITc) - 0.5 ''128 bit GUID / bit count rounded down for INT Dim encB As Long ''bit value per character Dim binStr As String ''Binary representation of number ''strName = VarName.value ''get value to work with strName = UCase(Trim(VarName.value)) ''force to UPPER for best results VarName.ClearComments If Len(strName) > MaxChar Then ''warn duplicates can exist VarName.AddCommentThreaded ("Warning, Check for duplicates" & MaxChar & " character maximim Exceeded.") Evaluate ("RangeWarn_Set(" & VarName.Address(False, False) & ")") ''Burns target cell with warning hatch ie = MaxChar strName = Left(strName, MaxChar) Else Evaluate ("RangeWarn_clear(" & VarName.Address(False, False) & ")") ie = Len(Left(strName, MaxChar)) '''''''''''''''''''<<<<<<<<<<<<<<DEBUG test 'If ie < 4 Then ie = 4 ''need every 4 characters to make up 3 hex pairs ie = Round((ie / 4) + 0.5, 0) * 4 End If For i = 1 To ie ''loop thorugh string name encB = enc5Bc(Mid(strName, i, 1)) ''Get char position in matrix <<NOTE BIT SIZE IN FUNCTION NAME! binStr = binStr & Dec2Bin(encB, x5b) ''ENCODE 6 BIT BINARY If i = MaxChar Then binStr = binStr & String(Len(binStr) Mod 8, "0") ''force last remainder bits to fill out to 8 bit chunk for hex End If ''check if 8 or more binaries to byte into a hex Do While Len(binStr) >= 8 HexStr = HexStr & Right("0" & Hex(Bin2Dec(Left(binStr, 8))), 2) binStr = Right(binStr, Len(binStr) - 8) Loop Next i Encode5Bit2HexGUID = 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 Encode5Bit2HexGUID = Format(Encode5Bit2HexGUID, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&")) End Function Function enc5Bc(x As String) As Integer enc5Bc = InStr(1, UCase(Base5b), UCase(Left(x, 1)), vbBinaryCompare) - 1 If enc5Bc = -1 Then enc5Bc = 0 ''substitute 1st character if not found (returns 0) End Function Sub x() Dim Target As Range Set Target = Sheet11.Range("C36") Stop RangeWarn_clear Target End Sub Sub RangeWarn_Set(Target As Range) ''Sets warning With Target.Interior .Pattern = xlLightUp .PatternColor = 10066431 .ColorIndex = xlAutomatic .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub Sub RangeWarn_clear(Target As Range) ''Clears warning ''https://docs.microsoft.com/en-us/office/vba/api/excel.xlpattern ''https://docs.microsoft.com/en-us/office/vba/api/excel.xlcolorindex With Target.Interior .Pattern = xlPatternNone .PatternColorIndex = xlColorIndexNone ' xlAutomatic .ColorIndex = xlColorIndexNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub