Attribute VB_Name = "StringHex" ' all these functions work with formatted hex strings ' this means strings that contain spaces or line changes are accepted Option Explicit Private Const CRYPT_HEX_FORMAT = "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long) Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long Private LH(0 To 5) As Long, LHP As Long Private LA() As Long, LP As Long Private IH(0 To 5) As Long, IHP As Long Private IA() As Integer, IP As Long Private BHex(0 To 511) As Long, BHexI As Boolean ' a very advanced function: allows for many kinds of formatting options and it is very fast too Public Function StringToHexString(Text As String, Optional Format As String = CRYPT_HEX_FORMAT, Optional Separator As String = vbNewLine, Optional ByVal Lowercase As Boolean = True) As String Dim B() As Byte, BytesPtr As Long, StringPtr As Long Dim C As Long, CH As Long, CL As Long, CS As Long, F() As Long, I As Long, J As Long, L As Long, LF As Long, LS As Long, P As Long ' calculate size L = LenB(Text) ' valid size If L > 0 Then ' safe arrays prepared for use? If IHP = 0 Then ' safe array: Long LH(0) = 1: LH(1) = 4: LH(4) = &H3FFFFFFF LHP = VarPtr(LH(0)) LP = ArrPtr(LA) ' safe array: Integer IH(0) = 1: IH(1) = 2 IHP = VarPtr(IH(0)) IP = ArrPtr(IA) End If ' hex array prepared for use? If BHexI = False Then For I = 0 To 255 ' upper case CH = ((I And &HF0&) \ &H10&) Or &H30& If CH > 57& Then CH = CH + 7& CL = (I And &HF&) Or &H30& If CL > 57& Then CL = CL + 7& BHex(I) = CH Or (CL * &H10000) ' lower case If CH > 64& Then CH = CH Or &H20& If CL > 64& Then CL = CL Or &H20& BHex(I Or 256&) = CH Or (CL * &H10000) Next I BHexI = True End If ' safe array: Long (first to get better speed) PutMem4 LP, LHP ' fast mode or format mode? If InStr(Format, "00") = 0 Then ' prepare buffer StringPtr = SysAllocStringByteLen(0, L * 4&) LH(3) = VarPtr(StringToHexString): LA(0) = StringPtr ' create a new empty byte array B = vbNullString ' pointer to safe array header BytesPtr = Not Not B: Debug.Assert App.hInstance ' point long array to byte array's header LH(3) = BytesPtr ' point byte array to Text string LA(3) = StrPtr(Text) LA(4) = L ' point long array to string buffer LH(3) = StringPtr ' convert the bytes If Lowercase = False Then For I = 0 To UBound(B): LA(I) = BHex(B(I)): Next Else For I = 0 To UBound(B): LA(I) = BHex(B(I) Or 256&): Next End If ' restore byte array to contain nothing LH(3) = BytesPtr: LA(3) = 0: LA(4) = 0 Else LF = Len(Format) LS = Len(Separator) ' find out how many bytes we output per line ReDim F(0 To LF \ 2 - 1) I = 0 Do Do: I = InStrB(I + 1, Format, "00") Loop Until (I = 0&) Or (I And 1&) = 1& If I <> 0& Then F(C) = (I - 1&) C = C + 1& I = I + 3 End If Loop Until I = 0& ReDim Preserve F(C - 1) ' calculate separator & amount of characters after last line CL = L - 1 If LS <> 0& Then CS = LS * (CL \ C) If (L Mod C) <> 0& Then CS = CS + F(CL Mod C) \ 2& + 2& ' prepare buffer StringPtr = SysAllocStringLen(0, LF * (L \ C) + CS) LH(3) = VarPtr(StringToHexString): LA(0) = StringPtr ' replicate Mid$(StringToHexString, 1, LF) = Format If Len(StringToHexString) > LF Then Mid$(StringToHexString, 1 + LF, LS) = Separator Mid$(StringToHexString, 1 + LF + LS) = StringToHexString End If ' create a new empty byte array B = vbNullString ' pointer to safe array header BytesPtr = Not Not B: Debug.Assert App.hInstance ' point long array to byte array's header LH(3) = BytesPtr ' point byte array to Text string LA(3) = StrPtr(Text) LA(4) = L ' set position to beginning of output string P = StringPtr LS = (LF + LS) * 2& ' convert the bytes If Lowercase = False Then For I = 0 To UBound(B) - C + 1 Step C For J = 0 To C - 1 LH(3) = P + F(J) LA(0) = BHex(B(I + J)) Next J P = P + LS Next I If (L Mod C) <> 0& Then For J = 0 To CL Mod C LH(3) = P + F(J) LA(0) = BHex(B(I + J)) Next J End If Else For I = 0 To UBound(B) - C + 1 Step C For J = 0 To C - 1 LH(3) = P + F(J) LA(0) = BHex(B(I + J) Or 256&) Next J P = P + LS Next I If (L Mod C) <> 0& Then For J = 0 To CL Mod C LH(3) = P + F(J) LA(0) = BHex(B(I + J) Or 256&) Next J End If End If ' restore byte array to contain nothing LH(3) = BytesPtr: LA(3) = 0: LA(4) = 0 End If ' safe array: Long LH(3) = LP: LA(0) = 0 End If End Function ' a very fast function that also allows for any kind of hex string input ' supports upper & lowercase and any non-hex character pair or lone character is simply ignored Public Function HexStringToString(Hex As String) As String Dim B() As Byte, C As Long, CH As Long, CL As Long, H As Long, I As Long, J As Long, L As Long, LB As Long L = Len(Hex) If L > 1 Then ' safe arrays prepared for use? If IHP = 0 Then ' safe array: Long LH(0) = 1: LH(1) = 4: LH(4) = &H3FFFFFFF LHP = VarPtr(LH(0)) LP = ArrPtr(LA) ' safe array: Integer IH(0) = 1: IH(1) = 2 IHP = VarPtr(IH(0)) IP = ArrPtr(IA) End If ' safe array: Long (first to get better speed) PutMem4 LP, LHP ' safe array: Integer LH(3) = IP: LA(0) = IHP ' output string byte length LB = L \ 2 ' point long array to output string LH(3) = VarPtr(HexStringToString) ' create a new string LA(0) = SysAllocStringByteLen(0, LB) ' access input string via Integer array IH(3) = StrPtr(Hex): IH(4) = L ' set long array to output data LH(3) = LA(0) Do ' byte 1 Do While I + 1 < L CH = IA(I) Select Case CH Case 48 To 57 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = ((CH And Not 48&) * &H10&) Or (CL And Not 48&) C = 1 Exit Do Case 65 To 70 H = ((CH And Not 48&) * &H10&) Or (CL - 55&) C = 1 Exit Do Case 97 To 102 H = ((CH And Not 48&) * &H10&) Or (CL - 87&) C = 1 Exit Do End Select Case 65 To 70 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = ((CH - 55&) * &H10&) Or (CL And Not 48&) C = 1 Exit Do Case 65 To 70 H = ((CH - 55&) * &H10&) Or (CL - 55&) C = 1 Exit Do Case 97 To 102 H = ((CH - 55&) * &H10&) Or (CL - 87&) C = 1 Exit Do End Select Case 97 To 102 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = ((CH - 87&) * &H10&) Or (CL And Not 48&) C = 1 Exit Do Case 65 To 70 H = ((CH - 87&) * &H10&) Or (CL - 55&) C = 1 Exit Do Case 97 To 102 H = ((CH - 87&) * &H10&) Or (CL - 87&) C = 1 Exit Do End Select End Select I = I + 1 Loop ' done? If I + 2 < L Then I = I + 1 Else Exit Do ' byte 2 Do While I + 1 < L CH = IA(I) Select Case CH Case 48 To 57 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH And Not 48&) * &H1000&) Or ((CL And Not 48&) * &H100&) C = 2 Exit Do Case 65 To 70 H = H Or ((CH And Not 48&) * &H1000&) Or ((CL - 55&) * &H100&) C = 2 Exit Do Case 97 To 102 H = H Or ((CH And Not 48&) * &H1000&) Or ((CL - 87&) * &H100&) C = 2 Exit Do End Select Case 65 To 70 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 55&) * &H1000&) Or ((CL And Not 48&) * &H100&) C = 2 Exit Do Case 65 To 70 H = H Or ((CH - 55&) * &H1000&) Or ((CL - 55&) * &H100&) C = 2 Exit Do Case 97 To 102 H = H Or ((CH - 55&) * &H1000&) Or ((CL - 87&) * &H100&) C = 2 Exit Do End Select Case 97 To 102 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 87&) * &H1000&) Or ((CL And Not 48&) * &H100&) C = 2 Exit Do Case 65 To 70 H = H Or ((CH - 87&) * &H1000&) Or ((CL - 55&) * &H100&) C = 2 Exit Do Case 97 To 102 H = H Or ((CH - 87&) * &H1000&) Or ((CL - 87&) * &H100&) C = 2 Exit Do End Select End Select I = I + 1 Loop ' done? If I + 2 < L Then I = I + 1 Else Exit Do ' byte 3 Do While I + 1 < L CH = IA(I) Select Case CH Case 48 To 57 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH And Not 48&) * &H100000) Or ((CL And Not 48&) * &H10000) C = 3 Exit Do Case 65 To 70 H = H Or ((CH And Not 48&) * &H100000) Or ((CL - 55&) * &H10000) C = 3 Exit Do Case 97 To 102 H = H Or ((CH And Not 48&) * &H100000) Or ((CL - 87&) * &H10000) C = 3 Exit Do End Select Case 65 To 70 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 55&) * &H100000) Or ((CL And Not 48&) * &H10000) C = 3 Exit Do Case 65 To 70 H = H Or ((CH - 55&) * &H100000) Or ((CL - 55&) * &H10000) C = 3 Exit Do Case 97 To 102 H = H Or ((CH - 55&) * &H100000) Or ((CL - 87&) * &H10000) C = 3 Exit Do End Select Case 97 To 102 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 87&) * &H100000) Or ((CL And Not 48&) * &H10000) C = 3 Exit Do Case 65 To 70 H = H Or ((CH - 87&) * &H100000) Or ((CL - 55&) * &H10000) C = 3 Exit Do Case 97 To 102 H = H Or ((CH - 87&) * &H100000) Or ((CL - 87&) * &H10000) C = 3 Exit Do End Select End Select I = I + 1 Loop ' done? If I + 2 < L Then I = I + 1 Else Exit Do ' byte 4 Do While I + 1 < L CH = IA(I) Select Case CH Case 48 To 55 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH And Not 48&) * &H10000000) Or ((CL And Not 48&) * &H1000000) C = 0 Exit Do Case 65 To 70 H = H Or ((CH And Not 48&) * &H10000000) Or ((CL - 55&) * &H1000000) C = 0 Exit Do Case 97 To 102 H = H Or ((CH And Not 48&) * &H10000000) Or ((CL - 87&) * &H1000000) C = 0 Exit Do End Select Case 56 To 57 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH And Not 56&) * &H10000000) Or ((CL And Not 48&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 65 To 70 H = H Or ((CH And Not 56&) * &H10000000) Or ((CL - 55&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 97 To 102 H = H Or ((CH And Not 56&) * &H10000000) Or ((CL - 87&) * &H1000000) Or &H80000000 C = 0 Exit Do End Select Case 65 To 70 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 63&) * &H10000000) Or ((CL And Not 48&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 65 To 70 H = H Or ((CH - 63&) * &H10000000) Or ((CL - 55&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 97 To 102 H = H Or ((CH - 63&) * &H10000000) Or ((CL - 87&) * &H1000000) Or &H80000000 C = 0 Exit Do End Select Case 97 To 102 I = I + 1 CL = IA(I) Select Case CL Case 48 To 57 H = H Or ((CH - 95&) * &H10000000) Or ((CL And Not 48&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 65 To 70 H = H Or ((CH - 95&) * &H10000000) Or ((CL - 55&) * &H1000000) Or &H80000000 C = 0 Exit Do Case 97 To 102 H = H Or ((CH - 95&) * &H10000000) Or ((CL - 87&) * &H1000000) Or &H80000000 C = 0 Exit Do End Select End Select I = I + 1 Loop ' write If C = 0 Then LA(J) = H: J = J + 1 ' done? If I + 2 < L Then I = I + 1 Else Exit Do Loop ' check for unwritten bytes & avoid buffer overwrite Select Case C Case 0 Case 1: LA(J) = (LA(J) And &HFFFFFF00) Or H Case 2: LA(J) = (LA(J) And &HFFFF0000) Or H Case 3: LA(J) = (LA(J) And &HFF000000) Or H End Select ' calculate final length L = J * 4 + C Select Case L Case LB ' do nothing! Case 0: HexStringToString = vbNullString Case Else: HexStringToString = LeftB$(HexStringToString, L) End Select ' safe array: Integer LH(3) = IP: LA(0) = 0 ' safe array: Long LH(3) = LP: LA(0) = 0 End If End Function