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 / HexStringAPI.bas < prev    next >
BASIC Source File  |  2011-02-07  |  4KB  |  81 lines
  1. Attribute VB_Name = "HexStringAPI"
  2. ' CryptoAPI versions
  3. Option Explicit
  4.  
  5. Private Const CRYPT_STRING_NOCR As Long = &H80000000
  6. Private Const CRYPT_STRING_NOCRLF As Long = &H40000000
  7. Private Const CRYPT_STRING_HEX As Long = 4&
  8.  
  9. Private Declare Function CryptBinaryToString Lib "Crypt32" Alias "CryptBinaryToStringW" (ByRef pbBinary As Byte, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long
  10. Private Declare Function CryptStringToBinary Lib "Crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
  11.  
  12. Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
  13. Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
  14. Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long
  15. Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long
  16.  
  17. Private LH(0 To 5) As Long, LHP As Long
  18. Private LA() As Long, LP As Long
  19.  
  20. Public Function BytesToHexString_C1(Bytes() As Byte, Optional ByVal Format As Boolean = True, Optional ByVal NewLine As Boolean = True, Optional ByVal Lowercase As Boolean = True) As String
  21.     Dim F As Long, L As Long, LB As Long, P As Long, UB As Long
  22.     P = Not Not Bytes: Debug.Assert App.hInstance
  23.     If P <> 0 Then
  24.         LB = LBound(Bytes)
  25.         UB = UBound(Bytes) + 1
  26.         If UB > LB Then
  27.             F = CRYPT_STRING_HEX Or (CLng(Not Format Or Not NewLine) And (CRYPT_STRING_NOCR Or CRYPT_STRING_NOCRLF))
  28.             If CryptBinaryToString(Bytes(LB), UB, F, 0, L) <> 0 Then
  29.                 P = SysAllocStringLen(0, L - 1)
  30.                 PutMem4 VarPtr(BytesToHexString_C1), P
  31.                 If CryptBinaryToString(Bytes(LB), UB, F, P, L) <> 0 Then
  32.                     If Not Format Then
  33.                         If InStr(BytesToHexString_C1, vbLf) <> 0 Then
  34.                             BytesToHexString_C1 = Replace(Replace(BytesToHexString_C1, vbLf, vbNullString), " ", vbNullString)
  35.                         Else
  36.                             BytesToHexString_C1 = Replace(BytesToHexString_C1, " ", vbNullString)
  37.                         End If
  38.                     End If
  39.                     If Not Lowercase Then BytesToHexString_C1 = UCase$(BytesToHexString_C1)
  40.                 Else
  41.                     BytesToHexString_C1 = vbNullString
  42.                 End If
  43.             End If
  44.         End If
  45.     End If
  46. End Function
  47.  
  48. Public Function HexStringToBytes_C1(Hex As String) As Byte()
  49.     Dim L As Long, LO As Long, P As Long, U As Long
  50.  
  51.     If LHP = 0 Then
  52.         LH(0) = 1: LH(1) = 4: LH(4) = &H7FFFFFFF
  53.         LHP = VarPtr(LH(0))
  54.         LP = ArrPtr(LA)
  55.     End If
  56.  
  57.     PutMem4 LP, LHP
  58.     
  59.     L = LenB(Hex) \ 4
  60.     LO = L - 6
  61.     If LO < 0 Then LO = 0
  62.     L = LO + 6
  63.     P = SysAllocStringByteLen(0, LO) - 4
  64.     LO = L
  65.     HexStringToBytes_C1 = vbNullString
  66.     LH(3) = Not Not HexStringToBytes_C1: Debug.Assert App.hInstance
  67.     LA(3) = P
  68.     LA(4) = L
  69.     
  70.     U = CLng(CryptStringToBinary(StrPtr(Hex), Len(Hex), CRYPT_STRING_HEX, P, LO, 0, U) <> 0&)
  71.     Select Case LO And U
  72.     Case L
  73.     Case 0
  74.         HexStringToBytes_C1 = vbNullString
  75.     Case Else
  76.         ReDim Preserve HexStringToBytes_C1(0 To LO - 1)
  77.     End Select
  78.  
  79.     LH(3) = LP: LA(0) = 0
  80. End Function
  81.