Excel VBA GUID Encoder
Attribute VB_Name = "CharEncode"
''''(C)
'
''(C)2019 Ron E. Allen all rights reserved
''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
Comments
Post a Comment