home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Hex_string219759262011.psc / HexStringSimple.bas < prev    next >
BASIC Source File  |  2011-02-06  |  12KB  |  286 lines
  1. Attribute VB_Name = "HexStringSimple"
  2. ' all these functions work with simple hex strings only
  3. ' this means the strings must not contain any formatting: no spaces, no linechanges or anything else
  4. Option Explicit
  5.  
  6. ' all declarations here are only used by S1 version of the function!
  7. Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
  8. Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
  9. Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long
  10.  
  11. Private LH(0 To 5) As Long, LHP As Long
  12. Private LA() As Long, LP As Long
  13.  
  14. Private IH(0 To 5) As Long, IHP As Long
  15. Private IA() As Integer, IP As Long
  16.  
  17. ' creates a "&H##" string by concatenation and then coerces the result to Byte
  18. ' result: this function is slow
  19. Public Function HexStringToBytes_H1(Hex As String) As Byte()
  20.     Dim B() As Byte, I As Long
  21.     ReDim B(Len(Hex) \ 2 - 1)
  22.     For I = 1 To Len(Hex) - 1 Step 2
  23.         B((I - 1) \ 2) = "&H" & Mid$(Hex, I, 2)
  24.     Next I
  25.     HexStringToBytes_H1 = B
  26. End Function
  27.  
  28. ' creates a "&H####" string by using a new copy of Hex as a buffer (passed ByVal)
  29. ' result: this function is slow, but roughly needs only half the processing time than above
  30. Public Function HexStringToBytes_H2(ByVal Hex As String) As Byte()
  31.     Dim C As Long, I As Long
  32.     ' the first two bytes have to be dealt using string concatenation
  33.     C = "&H" & Left$(Hex, 4)
  34.     ' beautiful math here, must be done to swap the bytes to correct order
  35.     Mid$(Hex, 1, 1) = ChrW$(((C And &HFF&) * &H100&) Or ((C And &HFF00&) \ &H100&))
  36.     For I = 3 To Len(Hex) - 5 Step 4
  37.         ' now, instead of string concatenation we place &H into Hex string
  38.         ' we save time because we do not create a new string
  39.         Mid$(Hex, I, 2) = "&H"
  40.         ' then coerce the result into a Long (here Mid$ creates a new string btw...)
  41.         C = Mid$(Hex, I, 6)
  42.         ' beautiful math here, must be done to swap the bytes to correct order
  43.         Mid$(Hex, ((I + 1) \ 4) + 1, 1) = ChrW$(((C And &HFF&) * &H100&) Or ((C And &HFF00&) \ &H100&))
  44.     Next I
  45.     ' and then the result
  46.     HexStringToBytes_H2 = LeftB$(Hex, Len(Hex) \ 2)
  47. End Function
  48.  
  49. ' original version: http://www.vbforums.com/showthread.php?p=3289346#post3289346
  50. ' gets character code by using AscW and then converts the characters to 4-bit parts of a byte
  51. ' result: this function is slow
  52. Public Function HexStringToBytes_A1(Hex As String) As Byte()
  53.     Dim B() As Byte, BH As Long, BL As Long, I As Long
  54.     If LenB(Hex) Then
  55.         ' reserve memory for output buffer
  56.         ReDim B(Len(Hex) \ 2 - 1)
  57.         ' jump by every two characters (in this case we happen to use byte positions for greater speed)
  58.         For I = 1 To LenB(Hex) - 3 Step 4
  59.             ' get the character value and decrease by 48
  60.             ' note: each MidB$ creates a new string
  61.             BH = AscW(MidB$(Hex, I, 2)) - 48&
  62.             BL = AscW(MidB$(Hex, I + 2, 2)) - 48&
  63.             ' move old A - F values down even more
  64.             If BH > 9 Then BH = BH - 7
  65.             If BL > 9 Then BL = BL - 7
  66.             ' combine the two 4 bit parts into a single byte
  67.             B(I \ 4) = ((BH And &HF&) * &H10&) Or (BL And &HF&)
  68.         Next I
  69.         ' return the output
  70.         HexStringToBytes_A1 = B
  71.     End If
  72. End Function
  73.  
  74. ' the same as above, but uses the passed Hex string as a buffer (passed ByVal)
  75. ' result: this function is slow
  76. Public Function HexStringToBytes_A2(ByVal Hex As String) As Byte()
  77.     Dim BH As Long, BL As Long, I As Long
  78.     If LenB(Hex) Then
  79.         ' jump by every two characters (in this case we happen to use byte positions for greater speed)
  80.         For I = 1 To LenB(Hex) - 3 Step 4
  81.             ' get the character value and decrease by 48
  82.             ' note: each MidB$ creates a new string
  83.             BH = AscW(MidB$(Hex, I, 2)) - 48&
  84.             BL = AscW(MidB$(Hex, I + 2, 2)) - 48&
  85.             ' move old A - F values down even more
  86.             If BH > 9 Then BH = BH - 7
  87.             If BL > 9 Then BL = BL - 7
  88.             ' combine the two 4 bit parts into a single byte
  89.             MidB$(Hex, ((I - 1) \ 4) + 1, 1) = ChrW$(((BH And &HF&) * &H10&) Or (BL And &HF&))
  90.         Next I
  91.         ' return the output
  92.         HexStringToBytes_A2 = LeftB$(Hex, (I - 1) \ 4)
  93.     End If
  94. End Function
  95.  
  96. ' 2011-01-31 "the quite insane version really"
  97. ' this function is long, but it does a few tricks to avoid any kind of speed bottlenecks
  98. ' result: the current fastest VB6 implementation known
  99. Public Function HexStringToBytes_S1(Hex As String) As Byte()
  100.     Dim C As Long, H As Long, L As Long, LB As Long
  101.     
  102.     ' ignore half byte information
  103.     L = Len(Hex) And Not 1
  104.     ' check length
  105.     If L >= 12 Then
  106.         ' safe arrays prepared for use?
  107.         If IHP = 0 Then
  108.             ' safe array: Long
  109.             LH(0) = 1: LH(1) = 4: LH(4) = &H3FFFFFFF
  110.             LHP = VarPtr(LH(0))
  111.             LP = ArrPtr(LA)
  112.             ' safe array: Integer
  113.             IH(0) = 1: IH(1) = 2
  114.             IHP = VarPtr(IH(0))
  115.             IP = ArrPtr(IA)
  116.         End If
  117.         ' safe array: Long
  118.         PutMem4 LP, LHP
  119.         ' safe array: Integer
  120.         LH(3) = IP: LA(0) = IHP
  121.         ' create an empty byte array
  122.         HexStringToBytes_S1 = vbNullString
  123.         ' length of byte array
  124.         LB = (L \ 2)
  125.         ' get pointer to safe array header for manipulation
  126.         LH(3) = Not Not HexStringToBytes_S1: Debug.Assert App.hInstance
  127.         ' create a BSTR, it works as our byte array!
  128.         LA(3) = SysAllocStringByteLen(0, LB - 6) - 4: LA(4) = LB
  129.         
  130.         IH(3) = StrPtr(Hex): IH(4) = L
  131.         ' set long array to output data (= byte array)
  132.         LH(3) = LA(3)
  133.         ' go through 8 hex string characters at a time = 4 bytes = 32-bits
  134.         For L = 0 To UBound(IA) - 7 Step 8
  135.             ' byte 1
  136.             C = IA(L + 1)
  137.             Select Case C
  138.                 Case 48 To 57: H = C And Not 48&
  139.                 Case 65 To 70: H = C - 55&
  140.                 Case Else: H = 0
  141.             End Select
  142.             C = IA(L)
  143.             Select Case C
  144.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10&)
  145.                 Case 65 To 70: H = H Or ((C - 55&) * &H10&)
  146.             End Select
  147.             ' byte 2
  148.             C = IA(L + 3)
  149.             Select Case C
  150.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H100&)
  151.                 Case 65 To 70: H = H Or ((C - 55&) * &H100&)
  152.             End Select
  153.             C = IA(L + 2)
  154.             Select Case C
  155.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H1000&)
  156.                 Case 65 To 70: H = H Or ((C - 55&) * &H1000&)
  157.             End Select
  158.             ' byte 3
  159.             C = IA(L + 5)
  160.             Select Case C
  161.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10000)
  162.                 Case 65 To 70: H = H Or ((C - 55&) * &H10000)
  163.             End Select
  164.             C = IA(L + 4)
  165.             Select Case C
  166.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H100000)
  167.                 Case 65 To 70: H = H Or ((C - 55&) * &H100000)
  168.             End Select
  169.             ' byte 4
  170.             C = IA(L + 7)
  171.             Select Case C
  172.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H1000000)
  173.                 Case 65 To 70: H = H Or ((C - 55&) * &H1000000)
  174.             End Select
  175.             C = IA(L + 6)
  176.             Select Case C
  177.                 Case 48 To 55: H = H Or ((C And Not 48&) * &H10000000)
  178.                 Case 56 To 57: H = H Or ((C And Not 56&) * &H10000000) Or &H80000000
  179.                 Case 65 To 70: H = H Or ((C - 63&) * &H10000000) Or &H80000000
  180.             End Select
  181.             ' write
  182.             LA(L \ 8) = H
  183.         Next L
  184.         
  185.         ' memory safety
  186.         Select Case (UBound(IA) + 1) - L
  187.         Case 0 ' we are done!
  188.         Case 2
  189.             ' read
  190.             H = LA(L \ 8) And &HFFFFFF00
  191.             ' byte 1
  192.             C = IA(L + 1)
  193.             Select Case C
  194.                 Case 48 To 57: H = H Or (C And Not 48&)
  195.                 Case 65 To 70: H = H Or (C - 55&)
  196.             End Select
  197.             C = IA(L)
  198.             Select Case C
  199.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10&)
  200.                 Case 65 To 70: H = H Or ((C - 55&) * &H10&)
  201.             End Select
  202.             ' write
  203.             LA(L \ 8) = H
  204.         Case 4
  205.             ' read
  206.             H = LA(L \ 8) And &HFFFF0000
  207.             ' byte 1
  208.             C = IA(L + 1)
  209.             Select Case C
  210.                 Case 48 To 57: H = H Or (C And Not 48&)
  211.                 Case 65 To 70: H = H Or (C - 55&)
  212.             End Select
  213.             C = IA(L)
  214.             Select Case C
  215.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10&)
  216.                 Case 65 To 70: H = H Or ((C - 55&) * &H10&)
  217.             End Select
  218.             ' byte 2
  219.             C = IA(L + 3)
  220.             Select Case C
  221.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H100&)
  222.                 Case 65 To 70: H = H Or ((C - 55&) * &H100&)
  223.             End Select
  224.             C = IA(L + 2)
  225.             Select Case C
  226.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H1000&)
  227.                 Case 65 To 70: H = H Or ((C - 55&) * &H1000&)
  228.             End Select
  229.             ' write
  230.             LA(L \ 8) = H
  231.         Case 6
  232.             ' read
  233.             H = LA(L \ 8) And &HFF000000
  234.             ' byte 1
  235.             C = IA(L + 1)
  236.             Select Case C
  237.                 Case 48 To 57: H = H Or (C And Not 48&)
  238.                 Case 65 To 70: H = H Or (C - 55&)
  239.             End Select
  240.             C = IA(L)
  241.             Select Case C
  242.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10&)
  243.                 Case 65 To 70: H = H Or ((C - 55&) * &H10&)
  244.             End Select
  245.             ' byte 2
  246.             C = IA(L + 3)
  247.             Select Case C
  248.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H100&)
  249.                 Case 65 To 70: H = H Or ((C - 55&) * &H100&)
  250.             End Select
  251.             C = IA(L + 2)
  252.             Select Case C
  253.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H1000&)
  254.                 Case 65 To 70: H = H Or ((C - 55&) * &H1000&)
  255.             End Select
  256.             ' byte 3
  257.             C = IA(L + 5)
  258.             Select Case C
  259.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H10000)
  260.                 Case 65 To 70: H = H Or ((C - 55&) * &H10000)
  261.             End Select
  262.             C = IA(L + 4)
  263.             Select Case C
  264.                 Case 48 To 57: H = H Or ((C And Not 48&) * &H100000)
  265.                 Case 65 To 70: H = H Or ((C - 55&) * &H100000)
  266.             End Select
  267.             ' write
  268.             LA(L \ 8) = H
  269.         End Select
  270.         ' end safearrays
  271.         LH(3) = IP: LA(0) = 0
  272.         LH(3) = LP: LA(0) = 0
  273.     ElseIf L > 0 Then
  274.         Dim B() As Byte, BL As Byte, BH As Byte
  275.         B = LeftB$(Hex, L \ 2)
  276.         For L = 0 To UBound(B)
  277.             BH = AscB(Mid$(Hex, L + L + 1, 1)) And Not 48
  278.             BL = AscB(Mid$(Hex, L + L + 2, 1)) And Not 48
  279.             If BH < 10 Then BH = BH * 16 Else BH = ((BH - 7) And 15) * 16
  280.             If BL < 10 Then B(L) = BL Or BH Else B(L) = ((BL - 7) And 15) Or BH
  281.         Next L
  282.         HexStringToBytes_S1 = B
  283.     End If
  284. End Function
  285.  
  286.