6 位（或 5 位）编码和解码 to/from 字符串以打包成 128 位伪 GUID
6-BIT (or 5 bit) encode and decode to/from strings for packing into 128 bit pseudo-GUIDs
（抱歉，如果这是重复的，但我的问题消失了 - 这个更详细）
我的名字需要转换成 'static' 的 'fixed' GUID。使用 ASCII-我有一个 GUID 代表一个 16 个字符的名称。我可以重新运行这些倒过来看看是不是我们的名字之一。但我想扩展它，所以我只使用一组索引字符，并且可以有效地将 16 个字符插入 GUID 的 128 位（ASCII-8 位 - 十六进制的 FF，易于伪造和解析）我只使用64 个字符，如果我能弄清楚如何在 VBA/EXCEL 中打包这些位，我可以将其减少到 6 位。如果我放弃上限，我可能会将其降低到 5 位。
使用 6 位或 5 位，我可以获得 128/5=25(r3) 位或 128/6=21(r2) 位的名称，或者这甚至可能吗？
所以索引看起来像：
''stripped character index tables
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'
'''''''''''''''''''0123456789x123456789x123456789x1
Const b32_5_bit = "()+.ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic text only naming
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''
'''''''''''''''''''0123456789x123456789x123456789x123456789x123456789x123456789x123
Const b64_6_bit = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ''Text and numbers naming
'''''''''''''''''''0'''---''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''''''''9'''''''''0'''''''''1'''''''''2
'''''''''''''''''''0123---456789x123456789x123456789x123456789x123456789x123456789x123456789x123459789x123456789x12345978
Const b128_7_bit = " !""""#$%&'()*+,-./0123456789:;<=>?@ABCEDFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcedfghijklmnopqrstufwxyz{|}~" ''Full printable characters for naming ''And on to more unused spaces....
我不知道如何打包 VBA 中的位，以便将它们解包。尝试屏蔽
2^6(n-1)+ 2^(Return 数组中字符的索引)
其中 (n) 是字符串掩码中的位置。此编码但未正确解码。
我即将恢复到一个 hack，我将其转换为二进制的字符串表示形式，然后一次蚕食 6 个字符并转换回索引。例如".a" = "000000" & "100100"
查看了散列法——但这并没有逆转（用于回溯检查）——以及其他一些东西——并一直在努力思考 6 位 base64 编号的来龙去脉。感谢任何帮助。
这是我对 GUID（base256-8 位）的文本的内容：
Attribute VB_Name = "Base16"
Option Explicit
Const HEX_STRING_PREFIX As String = "0x"
Const VBA_HEX_PREFIX As String = "&h"
''UUID record layout total numbers =32
''Name Length (bytes) Length (hex digits)Contents
''time_low 4 8 integer giving the low 32 bits of the time
''time_mid 2 4 integer giving the middle 16 bits of the time
''time_hi_and_version 2 4 4-bit "version" in the most significant bits, followed by the high 12 bits of the time
''clock_seq_hi_and_res clock_seq_low 2 4 1–3-bit "variant" in the most significant bits, followed by the 13–15-bit clock sequence
''node 6 12 the 48-bit node id
Public Function GUIDfromStr(Prefix As String, Variable As String) As String
''encodes decodeable GUID based on previx and a variable to run out to end of line (as many characters as possible)
''Used to generate GUIDS or UUIDs in a way that is identifiable
''PREFIX Is KTGY
''Variable is N...characters of variable name to encode to HEX for use as a GUID in parameter name generation. Not random but still random enough to backtrack.
''ASCII letters are encoded in hex pairs(0-255) and truncated
Prefix = UCase(Left(Prefix, 4))
GUIDfromStr = HexEncode(Prefix, "") & HexEncode(Variable, "")
GUIDfromStr = Left(GUIDfromStr & String(32, "0"), 32)
GUIDfromStr = Format(GUIDfromStr, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&"))
End Function
Public Function STRfromGUID(str As String) As String
''conver the first 8 characters, add a separator convert the remaining to reval up to 26 characters of parameter name
str = Replace(str, "-", "") ''remove the dashes
STRfromGUID = HexDecode(HEX_STRING_PREFIX & Left(str, 8)) _
& "|" _
& HexDecode(HEX_STRING_PREFIX & Right(str, Len(str) - 8))
End Function
Public Function HexEncode(AsciiText As String, Optional HexPrefix As String = HEX_STRING_PREFIX) As String
If AsciiText = vbNullString Then
HexEncode = AsciiText
Else
Dim asciiChars() As Byte
asciiChars = StrConv(AsciiText, vbFromUnicode)
ReDim hexChars(LBound(asciiChars) To UBound(asciiChars)) As String
Dim char As Long
For char = LBound(asciiChars) To UBound(asciiChars)
hexChars(char) = Right$("00" & Hex$(asciiChars(char)), 2)
Next char
HexEncode = HexPrefix & Join(hexChars, "")
End If
End Function
Public Function HexDecode(HexString As String, Optional HexPrefix As String = HEX_STRING_PREFIX)
'Check if there's anything to decode
If HexString = vbNullString Then
HexDecode = vbNullString
Exit Function
Else
If Not StrComp(Left$(HexString, Len(HexPrefix)), HexPrefix, vbTextCompare) = 0 Then
'Unexpected string format
GoTo DecodeError
End If
Dim hexRaw As String
hexRaw = Mid$(HexString, 1 + Len(HexPrefix))
'Check if the string is valid for decoding
If Len(hexRaw) Mod 2 = 1 Then
GoTo DecodeError
End If
Dim numHexChars As Long
numHexChars = Len(hexRaw) / 2
ReDim hexChars(0 To numHexChars - 1) As Byte
Dim char As Long
For char = 0 To numHexChars - 1
Dim hexchar As String
hexchar = VBA_HEX_PREFIX & Mid$(hexRaw, 1 + char * 2, 2)
'Check if the hex-pair is actually hex
If Not IsNumeric(hexchar) Then
GoTo DecodeError
End If
hexChars(char) = CByte(hexchar)
Next char
'Return the concatenated bytes as a string
HexDecode = StrConv(hexChars, vbUnicode)
End If
SafeExit:
Exit Function
DecodeError:
HexDecode = CVErr(xlErrValue)
End Function
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)) '''''''''''''''''''<<<<<<<<<<<<<<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
enc6b = enc6Bc(Mid(strName, i, 1)) ''Get char position in matrix
binStr = binStr & Dec2Bin(enc6b, 6) ''ENCODE 6 BIT BINARY
If i = MaxChar Then binStr = binStr & "00" ''force last two bits 1 & 2 to register to process byte
''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
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<MAX
Debug.Print Encode6Bit2HexGUID("zzzz................z")
'''''''''''''''''''''''equals = FFFFFF00-0000-0000-0000-0000000000FC
End Sub
Private Sub test_String_from_6Bit2HexGUID()
Const StrEncode = "__.CLEAR.HARD12345678"
'''''''''''''''''''0 1 2
'123456789012345687901<MAX
Debug.Print StrEncode
Debug.Print Encode6Bit2HexGUID(StrEncode)
Debug.Print String_from_6Bit2HexGUID(Encode6Bit2HexGUID(StrEncode))
End Sub
Private Sub printASCII()
Dim i
Dim str
For i = 32 To 126
str = str & Chr(i)
Next i
Debug.Print str
End Sub
（抱歉，如果这是重复的，但我的问题消失了 - 这个更详细） 我的名字需要转换成 'static' 的 'fixed' GUID。使用 ASCII-我有一个 GUID 代表一个 16 个字符的名称。我可以重新运行这些倒过来看看是不是我们的名字之一。但我想扩展它，所以我只使用一组索引字符，并且可以有效地将 16 个字符插入 GUID 的 128 位（ASCII-8 位 - 十六进制的 FF，易于伪造和解析）我只使用64 个字符，如果我能弄清楚如何在 VBA/EXCEL 中打包这些位，我可以将其减少到 6 位。如果我放弃上限，我可能会将其降低到 5 位。
使用 6 位或 5 位，我可以获得 128/5=25(r3) 位或 128/6=21(r2) 位的名称，或者这甚至可能吗？ 所以索引看起来像：
''stripped character index tables
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'
'''''''''''''''''''0123456789x123456789x123456789x1
Const b32_5_bit = "()+.ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic text only naming
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''
'''''''''''''''''''0123456789x123456789x123456789x123456789x123456789x123456789x123
Const b64_6_bit = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ''Text and numbers naming
'''''''''''''''''''0'''---''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''''''''9'''''''''0'''''''''1'''''''''2
'''''''''''''''''''0123---456789x123456789x123456789x123456789x123456789x123456789x123456789x123459789x123456789x12345978
Const b128_7_bit = " !""""#$%&'()*+,-./0123456789:;<=>?@ABCEDFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcedfghijklmnopqrstufwxyz{|}~" ''Full printable characters for naming ''And on to more unused spaces....
我不知道如何打包 VBA 中的位，以便将它们解包。尝试屏蔽 2^6(n-1)+ 2^(Return 数组中字符的索引)
其中 (n) 是字符串掩码中的位置。此编码但未正确解码。
我即将恢复到一个 hack，我将其转换为二进制的字符串表示形式，然后一次蚕食 6 个字符并转换回索引。例如".a" = "000000" & "100100"
查看了散列法——但这并没有逆转（用于回溯检查）——以及其他一些东西——并一直在努力思考 6 位 base64 编号的来龙去脉。感谢任何帮助。
这是我对 GUID（base256-8 位）的文本的内容：
Attribute VB_Name = "Base16"
Option Explicit
Const HEX_STRING_PREFIX As String = "0x"
Const VBA_HEX_PREFIX As String = "&h"
''UUID record layout total numbers =32
''Name Length (bytes) Length (hex digits)Contents
''time_low 4 8 integer giving the low 32 bits of the time
''time_mid 2 4 integer giving the middle 16 bits of the time
''time_hi_and_version 2 4 4-bit "version" in the most significant bits, followed by the high 12 bits of the time
''clock_seq_hi_and_res clock_seq_low 2 4 1–3-bit "variant" in the most significant bits, followed by the 13–15-bit clock sequence
''node 6 12 the 48-bit node id
Public Function GUIDfromStr(Prefix As String, Variable As String) As String
''encodes decodeable GUID based on previx and a variable to run out to end of line (as many characters as possible)
''Used to generate GUIDS or UUIDs in a way that is identifiable
''PREFIX Is KTGY
''Variable is N...characters of variable name to encode to HEX for use as a GUID in parameter name generation. Not random but still random enough to backtrack.
''ASCII letters are encoded in hex pairs(0-255) and truncated
Prefix = UCase(Left(Prefix, 4))
GUIDfromStr = HexEncode(Prefix, "") & HexEncode(Variable, "")
GUIDfromStr = Left(GUIDfromStr & String(32, "0"), 32)
GUIDfromStr = Format(GUIDfromStr, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&"))
End Function
Public Function STRfromGUID(str As String) As String
''conver the first 8 characters, add a separator convert the remaining to reval up to 26 characters of parameter name
str = Replace(str, "-", "") ''remove the dashes
STRfromGUID = HexDecode(HEX_STRING_PREFIX & Left(str, 8)) _
& "|" _
& HexDecode(HEX_STRING_PREFIX & Right(str, Len(str) - 8))
End Function
Public Function HexEncode(AsciiText As String, Optional HexPrefix As String = HEX_STRING_PREFIX) As String
If AsciiText = vbNullString Then
HexEncode = AsciiText
Else
Dim asciiChars() As Byte
asciiChars = StrConv(AsciiText, vbFromUnicode)
ReDim hexChars(LBound(asciiChars) To UBound(asciiChars)) As String
Dim char As Long
For char = LBound(asciiChars) To UBound(asciiChars)
hexChars(char) = Right$("00" & Hex$(asciiChars(char)), 2)
Next char
HexEncode = HexPrefix & Join(hexChars, "")
End If
End Function
Public Function HexDecode(HexString As String, Optional HexPrefix As String = HEX_STRING_PREFIX)
'Check if there's anything to decode
If HexString = vbNullString Then
HexDecode = vbNullString
Exit Function
Else
If Not StrComp(Left$(HexString, Len(HexPrefix)), HexPrefix, vbTextCompare) = 0 Then
'Unexpected string format
GoTo DecodeError
End If
Dim hexRaw As String
hexRaw = Mid$(HexString, 1 + Len(HexPrefix))
'Check if the string is valid for decoding
If Len(hexRaw) Mod 2 = 1 Then
GoTo DecodeError
End If
Dim numHexChars As Long
numHexChars = Len(hexRaw) / 2
ReDim hexChars(0 To numHexChars - 1) As Byte
Dim char As Long
For char = 0 To numHexChars - 1
Dim hexchar As String
hexchar = VBA_HEX_PREFIX & Mid$(hexRaw, 1 + char * 2, 2)
'Check if the hex-pair is actually hex
If Not IsNumeric(hexchar) Then
GoTo DecodeError
End If
hexChars(char) = CByte(hexchar)
Next char
'Return the concatenated bytes as a string
HexDecode = StrConv(hexChars, vbUnicode)
End If
SafeExit:
Exit Function
DecodeError:
HexDecode = CVErr(xlErrValue)
End Function
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)) '''''''''''''''''''<<<<<<<<<<<<<<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
enc6b = enc6Bc(Mid(strName, i, 1)) ''Get char position in matrix
binStr = binStr & Dec2Bin(enc6b, 6) ''ENCODE 6 BIT BINARY
If i = MaxChar Then binStr = binStr & "00" ''force last two bits 1 & 2 to register to process byte
''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
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<MAX
Debug.Print Encode6Bit2HexGUID("zzzz................z")
'''''''''''''''''''''''equals = FFFFFF00-0000-0000-0000-0000000000FC
End Sub
Private Sub test_String_from_6Bit2HexGUID()
Const StrEncode = "__.CLEAR.HARD12345678"
'''''''''''''''''''0 1 2
'123456789012345687901<MAX
Debug.Print StrEncode
Debug.Print Encode6Bit2HexGUID(StrEncode)
Debug.Print String_from_6Bit2HexGUID(Encode6Bit2HexGUID(StrEncode))
End Sub
Private Sub printASCII()
Dim i
Dim str
For i = 32 To 126
str = str & Chr(i)
Next i
Debug.Print str
End Sub