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
Comments
Post a Comment