Excel VBA GUID Encoder

Attribute VB_Name = "CharEncode" '''Back-end VBA Excel parameter manager '''Updated 2023-09-29 failover for parameters accidentally using 5-9 (e.g. dates) in parameter encode; '''option LockBITc to FORCE bit depth to stay at 5 (Chars 5-9 would show as "." - bad for date-types) '''force UPPERCASE for 5 bit '''UPDATED 2023-07-13 reference verified for current encoding. ''(c)2021 Ron E. Allen- Shared with KTGY2018-2019 - All rights reserved ''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 - Allows 25 characters simplified- ignoring upper and lower case, numbers 1-4 only. Const x5b = 5 ''Encoding bitsize ''6 bit - Allows 21 characters simplified- CASE matters in revit parameters 'foo' is different from 'FOO' Const x6b = 6 ''Encoding bitsize ''7 bit - would only allow for 18 characters Const x7b = 7 ''Encoding bitsize ''8 bit - allows for 256 characters--Same as straight hex encoding xFF 256 bits - mostly 173 wasted spaces ''Public Const Base8b = ".ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789abcdefghijklmnopqrstuvwxyz !\" + VBQT + "#$%&'()*+:;=@^`" ''Const x8b = 8 ''---------------------------------------------------------------------------------------------------------------------------- ''BIT-Encode strings: Public Const Base5b = ".ABCDEFGHIJKLMNOPQRSTUVWXYZ_1234" Public Const Base6b = ".ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789abcdefghijklmnopqrstuvwxyz" Public Const Base7b = ".ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789abcdefghijklmnopqrstuvwxyz !\" + VBQT + "#$%&'()*+" ''---------------------------------------------------------------------------------------------------------------------------- Enum MyColor Red YellowThickDiag End Enum Public Function Encode_Guid_Available_Characters(BitNo As Integer) As String Select Case BitNo: Case 5 Encode_Guid_Available_Characters = Base5b Case 6 Encode_Guid_Available_Characters = Base6b Case 7 Encode_Guid_Available_Characters = Base7b Case Else Encode_Guid_Available_Characters = "Please limit encode to 5,6, or 7 bit." Exit Function End Select Encode_Guid_Available_Characters = BitNo & "-BIT MAX " & 128 \ BitNo & " Characters: " & VBQT & Encode_Guid_Available_Characters & VBQT End Function Private 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 Private 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 ' ================= Private 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 Private Function String_from_6Bit2HexGUID(strGUID As String) As String ''hidden from functions 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 Private 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 Encode_GUID(VarName As Range, Optional BITc As Integer = 5, Optional LockBITc As Boolean = False) 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 ''ie end of count either MaxChar or less Dim strName As String ''string to nibble Dim HexStr As String ''Hex string to build Dim MaxChar As Integer Dim encB As Long ''bit value per character Dim binStr As String ''Binary representation of number ''BITc check if we need to upgrade to longer check string 2023-09-29 If Not LockBITc Then ''BITc not locked, check if we need to expand #'s in particular! i = Len(VarName) If i > 25 Then i = 25 For i = 1 To i ''iterate up to 25 characters If Mid(VarName, i, 1) Like "[0,5-9]" Then ''need to expand to 6 bit! BITc = 6 ''force shorter string but allow more characters Exit For End If Next i End If MaxChar = (128 \ BITc) ''INT division "\" 128 bit GUID \ bit count- (rounddown) If BITc < 5 Then strName = UCase(Trim(VarName.Value)) ''force to UPPER for 5-bit Else strName = Trim(VarName.Value) ''leave case intact and trim spaces for 6-bit End If VarName.ClearComments If Len(strName) > MaxChar Then ''warn duplicates can exist VarName.AddCommentThreaded ( _ "WARNING: " & MaxChar & "-MAX Character Count for GUID Exceeded." _ & " Change names if duplicates appear in RED at left." _ & vbCr _ & VBQT & Left(VarName.Value, MaxChar) & VBQT & "<-#" & MaxChar) 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 Encode_GUID = 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 Encode_GUID = Format(Encode_GUID, 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 RangeWarn_Set(Target As Range, Optional colorSet As MyColor = MyColor.YellowThickDiag) ''Sets warning color and pattern for cells Select Case colorSet Case MyColor.Red With Target.Interior .Pattern = xlLightUp .PatternColor = 10066431 .Colorindex = xlAutomatic .TintAndShade = 0 .PatternTintAndShade = 0 End With Case Else '' MyColor.Yellow ''default to yellow With Target.Interior .Pattern = xlUp .PatternColor = 49407 .Colorindex = xlAutomatic .TintAndShade = 0 .PatternTintAndShade = 0 End With End Select 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