سلام.
الگوریتم RC4DigestToHex کمی مشکل داره. ببین میتونی مشکلشو حل کنی.
کد:
Option Explicit
Private Const ALG_CLASS_HASH As Long = (4 * 2 ^ 13)
Private Const ALG_CLASS_DATA_ENCRYPT = (3 < 13)
Private Const ALG_TYPE_STREAM = (4 < 9)
Private Const ALG_SID_RC4 = 1
Private Const ALG_SID_MD5 = 3
Private Const ALG_SID_SHA1 = 4
Private Const ALG_TYPE_ANY As Long = 0
Private Const CALG_MD5 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
'Private Const CALG_SHA1 = "0x00008004"
Private Const CALG_SHA1 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_SHA1)
Private Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const PROV_RSA_FULL As Long = 1
Private Const HP_HASHSIZE As Long = &H4
Private Const HP_HASHVAL As Long = &H2
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, pByte As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByRef Algid As Long, ByRef hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByRef hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByRef hHash As Long, ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByRef hProv As Long, ByRef dwFlags As Long) As Long
Public Function RC4DigestToHex(ByVal s As String) As String
Dim hContext As Long
Dim hHash As Long
Dim dwDataLen As Long
Dim b() As Byte
CryptAcquireContext hContext, vbNullChar, vbNullChar, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT
CryptCreateHash hContext, ByVal CALG_RC4, ByVal 0&, 0&, hHash
CryptHashData ByVal hHash, s, Len(s), 0
CryptGetHashParam hHash, HP_HASHSIZE, dwDataLen, 4, 0
ReDim b(dwDataLen - 1)
CryptGetHashParam hHash, HP_HASHVAL, b(0), dwDataLen, 0
Dim str As String, i As Long
For i = 0 To UBound(b)
str = str & HexChar(b(i))
Next i
RC4DigestToHex = LCase$(str)
CryptDestroyHash hHash
CryptReleaseContext hContext, ByVal 0&
End Function
Public Function MD5DigestToHex(ByVal s As String) As String
Dim hContext As Long
Dim hHash As Long
Dim dwDataLen As Long
Dim b() As Byte
CryptAcquireContext hContext, vbNullChar, vbNullChar, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT
CryptCreateHash hContext, ByVal CALG_MD5, ByVal 0&, 0&, hHash
CryptHashData ByVal hHash, s, Len(s), 0
CryptGetHashParam hHash, HP_HASHSIZE, dwDataLen, 4, 0
ReDim b(dwDataLen - 1)
CryptGetHashParam hHash, HP_HASHVAL, b(0), dwDataLen, 0
Dim str As String, i As Long
For i = 0 To UBound(b)
str = str & HexChar(b(i))
Next i
MD5DigestToHex = LCase$(str)
CryptDestroyHash hHash
CryptReleaseContext hContext, ByVal 0&
End Function
Public Function SHA1DigestToHex(ByVal s As String) As String
Dim hContext As Long
Dim hHash As Long
Dim dwDataLen As Long
Dim b() As Byte
CryptAcquireContext hContext, vbNullChar, vbNullChar, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT
CryptCreateHash hContext, ByVal CALG_SHA1, ByVal 0&, 0&, hHash
CryptHashData ByVal hHash, s, Len(s), 0
CryptGetHashParam hHash, HP_HASHSIZE, dwDataLen, 4, 0
ReDim b(dwDataLen - 1)
CryptGetHashParam hHash, HP_HASHVAL, b(0), dwDataLen, 0
Dim str As String, i As Long
For i = 0 To UBound(b)
str = str & HexChar(b(i))
Next i
SHA1DigestToHex = LCase$(str)
CryptDestroyHash hHash
CryptReleaseContext hContext, ByVal 0&
End Function
Private Function HexChar(ByVal b As Byte) As String
Dim s As String
s = Hex(b)
If Len(s) = 1 Then s = "0" & s
HexChar = s
End Function
ـــــــــــــــــــــــــــــــــــــــر