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:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
|
Option Explicit
Private Const CRYPT_NEWKEYSET = &H8
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" ( _
phProv As Long, pszContainer As String, pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private 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
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, _
ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private 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
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private 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
Private 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
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
'constants for Cryptography API functions
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_MD5 = 3
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_RC4
Private Const ENCRYPT_BLOCK_SIZE = 1
Private Const CRYPT_EXPORTABLE = 1
Public Function DoCryptoEncrypt(sPassword As String, PlainText As String) As String
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lHExchgKey As Long
Dim lHCryptprov As Long
Dim sContainer As String
Dim lCryptLength As Long
Dim lCryptBufLen As Long
Dim sCryptBuffer As String
On Error GoTo EncryptError
Dim sOutputBuffer As String
Dim sProvider
'Get handle to the default CSP
sProvider = MS_DEF_PROV & vbNullChar
If Len(PlainText) = 0 Then
DoCryptoEncrypt = ""
Exit Function
End If
sOutputBuffer = ""
If Not CBool(CryptAcquireContext(lHCryptprov, ByVal _
sContainer, ByVal 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&, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
sOutputBuffer = PlainText
GoTo Finished
End If
End If
End If
'Create a hash object
If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, _
0, lHHash)) Then
MsgBox ("Error " & CStr(GetLastError) & _
" during CryptCreateHash!")
GoTo Finished
End If
'Hash in the password text
If Not CBool(CryptHashData(lHHash, sPassword, _
Len(sPassword), 0)) Then
MsgBox ("Error " & CStr(GetLastError) & _
" during CryptHashData!")
GoTo Finished
End If
'Create a session key from the hash object.
If Not CBool(CryptDeriveKey(lHCryptprov, _
ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then
MsgBox ("Error " & CStr(GetLastError) & _
" during CryptDeriveKey!")
GoTo Finished
End If
'Destroy the hash object.
CryptDestroyHash (lHHash)
lHHash = 0
'Create a buffer for the CryptEncrypt function
lCryptLength = Len(PlainText)
lCryptBufLen = lCryptLength * 2
sCryptBuffer = String(lCryptBufLen, vbNullChar)
LSet sCryptBuffer = PlainText
'Encrypt the text data
If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer, _
lCryptLength, lCryptBufLen)) Then
MsgBox ("bytes required:" & CStr(lCryptLength))
MsgBox ("Error " & CStr(GetLastError) & _
" during CryptEncrypt!")
End If
sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
Finished:
'Outa here
DoCryptoEncrypt = sOutputBuffer
'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
EncryptError:
MsgBox ("Encrypt Error: " & Error$)
GoTo Finished
End Function
Public Function DoCryptoDecrypt(sPassword As String, CryptText 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 sContainer As String
Dim sProvider As String
Dim sCryptBuffer As String
Dim lCryptBufLen As Long
Dim lCryptPoint As Long
Dim lPasswordPoint As Long
Dim lPasswordCount As Long
Dim sOutputBuffer As String
On Error GoTo DecryptError
If Len(CryptText) = 0 Then
DoCryptoDecrypt = ""
Exit Function
End If
'Clear the Output buffer
sOutputBuffer = ""
'Get handle to the default CSP.
sContainer = vbNullChar
sProvider = vbNullChar
sProvider = MS_DEF_PROV & vbNullChar
If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
'MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext! ")"
sOutputBuffer = CryptText
GoTo Finished
End If
End If
'Create a hash object
If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash! ")
GoTo Finished
End If
'Hash in the password text
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")
GoTo Finished
End If
'Create a session key from the hash object
If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then
MsgBox ("Error " & CStr(GetLastError) & " during CryptDeriveKey!")
GoTo Finished
End If
'Destroy the hash object.
CryptDestroyHash (lHHash)
lHHash = 0
'Prepare sCryptBuffer for CryptDecrypt
lCryptBufLen = Len(CryptText) * 2
sCryptBuffer = String(lCryptBufLen, vbNullChar)
LSet sCryptBuffer = CryptText
'Decrypt data
If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then
MsgBox ("bytes required:" & CStr(lCryptBufLen))
MsgBox ("Error " & CStr(GetLastError) & " during CryptDecrypt!")
GoTo Finished
End If
'Setup output buffer with just decrypted data
sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptBufLen / 2)
Finished:
'Outa here
DoCryptoDecrypt = sOutputBuffer
'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 ("Decrypt Error: " & Error$)
GoTo Finished
End Function
|
