1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
|
Public Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" ( _
phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Public Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, _
ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
Public Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, _
ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Public Declare Function CryptDeriveKey Lib "advapi32.dll" ( _
ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, _
phKey As Long) As Long
Public Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Public Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hKey As Long, _
ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, _
pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Public Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hKey As Long, _
ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, _
pdwDataLen As Long) As Long
Public Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, _
ByVal dwFlags As Long) As Long
Public Declare Function GetLastError Lib "kernel32" () As Long
'constants for Cryptography API functions
Private Const CRYPT_NEWKEYSET = &H8
Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL = 1
Private Const ALG_CLASS_DATA_ENCRYPT = 24576
Private Const ALG_CLASS_HASH = 32768
Private Const ALG_TYPE_ANY = 0
Private Const ALG_TYPE_BLOCK = 1536
Private Const ALG_TYPE_STREAM = 2048
Private Const ALG_SID_RC2 = 2
Private Const ALG_SID_RC4 = 1
Private Const ALG_SID_SHA1 = 4
Private Const ALG_SID_MD5 = 3
Private Const CALG_SHA1 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_SHA1)
Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or ALG_SID_RC2)
Private Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
Private Const ENCRYPT_ALGORITHM = CALG_RC2
Private Const ENCRYPT_BLOCK_SIZE = 1
Private Const CRYPT_EXPORTABLE = 1
' used to specify not to use any salt value while deriving the key
Private Const CRYPT_NO_SALT As Long = &H10
Private Function CryptoDecrypt(sInputBuffer As String, sPassword As String, ByRef sErrore As String) As String
Dim lHExchgKey As Long
Dim lHCryptprov As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim sProvider As String
Dim sCryptBuffer As String
Dim lCryptBufLen As Long
Dim lCryptPoint As Long
Dim lPasswordPoint As Long
Dim lPasswordCount As Long
On Error GoTo DecryptError
'get handle to the default CSP.
sProvider = vbNullChar
sProvider = MS_DEF_PROV & vbNullChar
If Not CBool(CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, 0)) Then
'If there is no default key container then create one using Flags field
If GetLastError = 0 Then
If Not CBool(CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
GoTo Finished
End If
End If
End If
'Create a hash object
If Not CBool(CryptCreateHash(lHCryptprov, CALG_SHA1, 0, 0, lHHash)) Then
GoTo Finished
End If
'Hash in the password text
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
GoTo Finished
End If
'Create a session key from the hash object
If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, ByVal CRYPT_NO_SALT, lHkey)) Then
GoTo Finished
End If
'Destroy the hash object.
CryptDestroyHash (lHHash)
lHHash = 0
'Prepare sCryptBuffer for CryptDecrypt
lCryptBufLen = Len(sInputBuffer)
sCryptBuffer = String(lCryptBufLen, vbNullChar)
LSet sCryptBuffer = sInputBuffer
'Decrypt data
If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then
GoTo Finished
End If
'Setup output buffer with just decrypted data
CryptoDecrypt = Mid(sCryptBuffer, 1, lCryptBufLen)
Finished:
'Destroy session key
If (lHkey) Then lResult = CryptDestroyKey(lHkey)
'Destroy key exchange key handle
If lHExchgKey Then CryptDestroyKey (lHExchgKey)
'Destroy hash object
If lHHash Then CryptDestroyHash (lHHash)
'Release Context provider handle
If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
Exit Function
DecryptError:
msgbox (GetLastError )
End Function |
