加密字符串算法
作者：junk.Damage.CaseThis is an example of REAL encryption. Not that ASCII addition/subtraction junk.Damage.Case http://www.alchemydev.com/'Just put this in a form. And figure out how to
'call them yourself.'This is how encryption is done boys and girls.
'I'm sick of seeing posts of encryption routines
'that add and subtract to the ascii number of a
'character. It's very ineffective. Decryption
'programs can crack simple stuff like that in
'less than a second. Do it right.'Note: Don't make the key repetative in any way!Option ExplicitPrivate Function Decrypt(PlainStr As String, key As String)
Dim Char As String, KeyChar As String, NewStr As String
Dim Pos As Integer
Dim i As Integer, Side1 As String, Side2 As String
Pos = 1'This is a little trick to make it slightly harder to crack.
'However, the chances of this operation firing is 50/50
'because the length of the string must be divisable by 2.
If Len(PlainStr) Mod 2 = 0 Then
Side1 = StrReverse(Left(PlainStr, (Len(PlainStr) / 2)))
Side2 = StrReverse(Right(PlainStr, (Len(PlainStr) / 2)))
PlainStr = Side1 & Side2
End If'This loop decrypts the data.
For i = 1 To Len(PlainStr)
Char = Mid(PlainStr, i, 1)
KeyChar = Mid(key, Pos, 1)
NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
If Pos = Len(key) Then Pos = 0
Pos = Pos + 1
Next iDecrypt = NewStr
End FunctionPrivate Function Encrypt(PlainStr As String, key As String)
Dim Char As String, KeyChar As String, NewStr As String
Dim Pos As Integer
Dim i As Integer, Side1 As String, Side2 As String
Pos = 1'This loop encrypts the data.
For i = 1 To Len(PlainStr)
Char = Mid(PlainStr, i, 1)
KeyChar = Mid(key, Pos, 1)
NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
If Pos = Len(key) Then Pos = 0
Pos = Pos + 1
Next i'This is a little trick to make it slightly harder to crack.
'However, the chances of this operation firing is 50/50
'because the length of the string must be divisable by 2.
If Len(NewStr) Mod 2 = 0 Then
Side1 = StrReverse(Left(NewStr, (Len(NewStr) / 2)))
Side2 = StrReverse(Right(NewStr, (Len(NewStr) / 2)))
NewStr = Side1 & Side2
End IfEncrypt = NewStr
End Function
作者：junk.Damage.CaseThis is an example of REAL encryption. Not that ASCII addition/subtraction junk.Damage.Case http://www.alchemydev.com/'Just put this in a form. And figure out how to
'call them yourself.'This is how encryption is done boys and girls.
'I'm sick of seeing posts of encryption routines
'that add and subtract to the ascii number of a
'character. It's very ineffective. Decryption
'programs can crack simple stuff like that in
'less than a second. Do it right.'Note: Don't make the key repetative in any way!Option ExplicitPrivate Function Decrypt(PlainStr As String, key As String)
Dim Char As String, KeyChar As String, NewStr As String
Dim Pos As Integer
Dim i As Integer, Side1 As String, Side2 As String
Pos = 1'This is a little trick to make it slightly harder to crack.
'However, the chances of this operation firing is 50/50
'because the length of the string must be divisable by 2.
If Len(PlainStr) Mod 2 = 0 Then
Side1 = StrReverse(Left(PlainStr, (Len(PlainStr) / 2)))
Side2 = StrReverse(Right(PlainStr, (Len(PlainStr) / 2)))
PlainStr = Side1 & Side2
End If'This loop decrypts the data.
For i = 1 To Len(PlainStr)
Char = Mid(PlainStr, i, 1)
KeyChar = Mid(key, Pos, 1)
NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
If Pos = Len(key) Then Pos = 0
Pos = Pos + 1
Next iDecrypt = NewStr
End FunctionPrivate Function Encrypt(PlainStr As String, key As String)
Dim Char As String, KeyChar As String, NewStr As String
Dim Pos As Integer
Dim i As Integer, Side1 As String, Side2 As String
Pos = 1'This loop encrypts the data.
For i = 1 To Len(PlainStr)
Char = Mid(PlainStr, i, 1)
KeyChar = Mid(key, Pos, 1)
NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
If Pos = Len(key) Then Pos = 0
Pos = Pos + 1
Next i'This is a little trick to make it slightly harder to crack.
'However, the chances of this operation firing is 50/50
'because the length of the string must be divisable by 2.
If Len(NewStr) Mod 2 = 0 Then
Side1 = StrReverse(Left(NewStr, (Len(NewStr) / 2)))
Side2 = StrReverse(Right(NewStr, (Len(NewStr) / 2)))
NewStr = Side1 & Side2
End IfEncrypt = NewStr
End Function
在VB中，由于随机数生成器是伪随机数，所以根据其原理可以用于文本的
加密和解密，根据异或逻辑运算，加密和解密可以是同一个过程。
加密与解密函数代码如下。'加密与解密函数说明:
' CharSting 加密或解密的数据
' Key 加密或解密的密钥
'函数返回值:
' 1. CharString为空时返回"1"
' 2. 加密或解密失败返回"0"
' 3. 成功则返回加密或解密后的字符串
Public Function EDcode$(CharString As String, Key As Integer)
Dim X As Single, i As Long
Dim CharNum As Integer, RandomInteger As Integer
Dim CharSingle As String * 1
On Local Error GoTo EDcodeError
EDcode$ = ""
If Len(CharString) = 0 Then
EDcode$ = "1"
Exit Function
End If
X = Rnd(-Key)
For i = 1 To Len(CharString)
CharSingle = Mid$(CharString, i, 1)
CharNum = Asc(CharSingle)
RandomInteger = Int(256 * Rnd) And &H7F
CharNum = CharNum Xor RandomInteger
CharSingle = Chr$(CharNum)
EDcode$ = EDcode$ + CharSingle
Next i
Exit Function
EDcodeError:
EDcode$ = "0"
End Function
我的思路是这样的。将文件的内容与一个字符串的字符循环Xor。
比如：密钥是k28h5
则第一个字节和k做xor，第二个和2做xor……第六个还是和k做xor……如此循环。
PassStart=Address Mod PassLong
第Address个字节和密钥字符串的第PassStart个字符做xor。
大概原理是这样，具体实现就涉及到许多问题。比如是一个字节还是两个字节的问题。 这是我编写的一组加密文件的核心函数。无论对文件加密还是对字符串加密都可以应用。（你可以把文件变成Bytes()数组来加密，相信你也知道如何去做。）完全兼容中文（兼容对中文字符串加密，也兼容中文密钥。）Function StringGetByBytes(pBytes() As Byte) As String
'从Byte数组获得字符串[兼容中文]
Dim tOutStr As String
Dim tLoop As Integer
Dim tByteLen As Integer
tByteLen = UBound(pBytes)
For tLoop = 0 To tByteLen
tOutStr = tOutStr & ChrB(pBytes(tLoop))
Next
StringGetByBytes = tOutStr
End FunctionFunction BytesGetByString(pString As String, pBytes() As Byte)
'将字符串保存到数组[兼容中文]
Dim tStrLength As Integer
Dim tLoop As Integer
Dim tCodeStart As Byte
tStrLength = LenB(pString)
For tLoop = 1 To tStrLength
tCodeStart = AscB(MidB(pString, tLoop, 1))
ReDim Preserve pBytes(tLoop - 1)
pBytes(tLoop - 1) = tCodeStart
Next
End FunctionFunction EncryptBytesGet(pBytes() As Byte, pKeyWords() As Byte)
'根据一个密钥加密一个Byte数组
Dim tByteStart As Long
Dim tByteEnd As Long
Dim tByteOn As Long
Dim tKeyStart As Integer
Dim tKeyLen As Integer
tByteEnd = UBound(pBytes)
tByteOn = LBound(pBytes)
tKeyLen = UBound(pKeyWords) + 1
For tByteStart = tByteOn To tByteEnd
tKeyStart = tByteStart Mod tKeyLen
pBytes(tByteStart) = pBytes(tByteStart) Xor pKeyWords(tKeyStart)
Next
End FunctionFunction EncryptKeyWordsGetByString(pKeyStr As String, pKeyWords() As Byte) As Integer
'根据一个字符串获得密钥Byte数组。
Dim tStrLength As Integer
Dim tLoop As Integer
Dim tCodeStart As Byte
Dim tArrayLen As Integer
tStrLength = LenB(pKeyStr)
For tLoop = 1 To tStrLength
tCodeStart = AscB(MidB(pKeyStr, tLoop, 1))
If tCodeStart Then
ReDim Preserve pKeyWords(tArrayLen)
pKeyWords(tArrayLen) = tCodeStart
tArrayLen = tArrayLen + 1
End If
Next
EncryptKeyWordsGetByString = tArrayLen
End Function这个程序是一个网友要的，目的是将一个二进制文件加密和解密！！算法就是最基本的XOR，因为我从前重来没有做过二进制文件的操作，所以有些地方欢迎大家提出修改意见，另外我是这两天才到这里来的，没什么分！所以这个帖子实在是给不了多少我一共就58分能用，请大家见谅！
Private Sub Form_Load()
EDcode "d:\234.dat", "d:\123.dat"
End Sub'******************************************************************************
' 目的: 文本加密解密
' 输入: FileName 加密解密的文件
' OutName 结果文件
'函数返回值:
' 日期: 2002/01/24
' 作者: 陈颂雷
' E-Mail:[email protected]
'******************************************************************************
Public Sub EDcode(FileName As String, OutName As String)
Dim x As Single, I As Long, L As Long
Dim CharNum As Integer, PassInteger As Integer
Dim CharSingle As Byte
Dim CharString As String * 1
Const PassW = "ABCDEFGHJKLMNopu" '17个字长的加密串必须为英文
On Local Error GoTo EDcodeError
Open FileName For Binary As #1
I = 1
L = 1
Do While Not EOF(1)
DoEvents
Get #1, , CharSingle
Open "c:\temp.dat" For Binary As #2
If L = 17 Then L = 1
PassInteger = Asc(Mid$(PassW, L, 1))
CharNum = CharSingle Xor PassInteger
Put #2, I, CharNum
L = L + 1
I = I + 1
Close #2
Loop
Close #1
'希望下面的代码能够省掉,但是不加这个就会长出两个字节,再解密就是长出4个字节了
'各位高手能否给看看?
Open "c:\temp.dat" For Binary As #1
For I = 1 To I - 2
Get #1, , CharSingle
Open OutName For Binary As #2
Put #2, I, CharSingle
Close #2
Next I
Close #1
Kill "c:\temp.dat"
Exit Sub
EDcodeError:
MsgBox "错"
End Sub
另外支持中文的语句如下，将
PassInteger = Asc(Mid$(PassW, L, 1))
CharNum = CharSingle Xor PassInteger
之中加入
PassInteger=PassInteger And &H7F
或者
PassInteger=PassInteger And 127
没有经过测试，我想原理差不多
Public key(1 To 3) As Long
Private Const base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrst
uvwxyz0123456789+/" Public Sub GenKey()
Dim d As Long, phi As Long, e As Long
Dim m As Long, x As Long, q As Long
Dim p As Long
Randomize
On Error GoTo top
top:
p = Rnd * 1000 \ 1
If IsPrime(p) = False Then GoTo top
Sel_q:
q = Rnd * 1000 \ 1
If IsPrime(q) = False Then GoTo Sel_q
n = p * q \ 1
phi = (p - 1) * (q - 1) \ 1
d = Rnd * n \ 1
If d = 0 Or n = 0 Or d = 1 Then GoTo top
e = Euler(phi, d)
If e = 0 Or e = 1 Then GoTo top x = Mult(255, e, n)
If Not Mult(x, d, n) = 255 Then
DoEvents
GoTo top
ElseIf Mult(x, d, n) = 255 Then
key(1) = e
key(2) = d
key(3) = n
End If
End Sub Private Function Euler(ByVal a As Long, ByVal b As Long) As Long
On Error GoTo error2
r1 = a: r = b
p1 = 0: p = 1
q1 = 2: q = 0
n = -1
Do Until r = 0
r2 = r1: r1 = r
p2 = p1: p1 = p
q2 = q1: q1 = q
n = n + 1
r = r2 Mod r1
c = r2 \ r1
p = (c * p1) + p2
q = (c * q1) + q2
Loop
s = (b * p1) - (a * q1)
If s > 0 Then
x = p1
Else
x = (0 - p1) + a
End If
Euler = x
Exit Function error2:
Euler = 0
End Function Private Function Mult(ByVal x As Long, ByVal p As Long, ByVal m As Lon
g) As Long
y = 1
On Error GoTo error1
Do While p > 0
Do While (p / 2) = (p \ 2)
x = (x * x) Mod m
p = p / 2
Loop
y = (x * y) Mod m
p = p - 1
Loop
Mult = y
Exit Function error1:
y = 0
End Function Private Function IsPrime(lngNumber As Long) As Boolean
Dim lngCount As Long
Dim lngSqr As Long
Dim x As Long lngSqr = Sqr(lngNumber) ' get the int square root If lngNumber < 2 Then
IsPrime = False
Exit Function
End If lngCount = 2
IsPrime = True If lngNumber Mod lngCount = 0& Then
IsPrime = False
Exit Function
End If lngCount = 3 For x& = lngCount To lngSqr Step 2
If lngNumber Mod x& = 0 Then
IsPrime = False
Exit Function
End If
Next
End Function Private Function Base64_Encode(DecryptedText As String) As String
Dim c1, c2, c3 As Integer
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim w4 As Integer
Dim n As Integer
Dim retry As String
For n = 1 To Len(DecryptedText) Step 3
c1 = Asc(Mid$(DecryptedText, n, 1))
c2 = Asc(Mid$(DecryptedText, n + 1, 1) + Chr$(0))
c3 = Asc(Mid$(DecryptedText, n + 2, 1) + Chr$(0))
w1 = Int(c1 / 4)
w2 = (c1 And 3) * 16 + Int(c2 / 16)
If Len(DecryptedText) >= n + 1 Then w3 = (c2 And 15) * 4 + Int(c
3 / 64) Else w3 = -1
If Len(DecryptedText) >= n + 2 Then w4 = c3 And 63 Else w4 = -1 retry = retry + mimeencode(w1) + mimeencode(w2) + mimeencode(w3)
+ mimeencode(w4)
Next
Base64_Encode = retry
End Function Private Function Base64_Decode(a As String) As String
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim w4 As Integer
Dim n As Integer
Dim retry As String For n = 1 To Len(a) Step 4
w1 = mimedecode(Mid$(a, n, 1))
w2 = mimedecode(Mid$(a, n + 1, 1))
w3 = mimedecode(Mid$(a, n + 2, 1))
w4 = mimedecode(Mid$(a, n + 3, 1))
If w2 >= 0 Then retry = retry + Chr$(((w1 * 4 + Int(w2 / 16)) An
d 255))
If w3 >= 0 Then retry = retry + Chr$(((w2 * 16 + Int(w3 / 4)) An
d 255))
If w4 >= 0 Then retry = retry + Chr$(((w3 * 64 + w4) And 255))
Next
Base64_Decode = retry
End Function Private Function mimeencode(w As Integer) As String
If w >= 0 Then mimeencode = Mid$(base64, w + 1, 1) Else mimeencode
= ""
End Function Private Function mimedecode(a As String) As Integer
If Len(a) = 0 Then mimedecode = -1: Exit Function
mimedecode = InStr(base64, a) - 1
End Function Public Function Encode(ByVal Inp As String, ByVal e As Long, ByVal n A
s Long) As String
Dim s As String
s = ""
m = Inp If m = "" Then Exit Function
s = Mult(CLng(Asc(Mid(m, 1, 1))), e, n)
For i = 2 To Len(m)
s = s & "+" & Mult(CLng(Asc(Mid(m, i, 1))), e, n)
Next i
Encode = Base64_Encode(s)
End Function Public Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n A
s Long) As String
St = ""
ind = Base64_Decode(Inp)
For i = 1 To Len(ind)
nxt = InStr(i, ind, "+")
If Not nxt = 0 Then
tok = Val(Mid(ind, i, nxt))
Else
tok = Val(Mid(ind, i))
End If
St = St + Chr(Mult(CLng(tok), d, n))
If Not nxt = 0 Then
i = nxt
Else
i = Len(ind)
End If
Next i
Decode = St
End Function rc4
Public Sub main()
Dim key As String
For i = 1 To 16
Randomize
key = key & Chr(Rnd * 255)
Next i
MsgBox RC4(RC4("Welcome To Plindge Studio!", key), key)
End Sub
Public Function RC4(inp As String, key As String) As String
Dim S(0 To 255) As Byte, K(0 To 255) As Byte, i As Long
Dim j As Long, temp As Byte, Y As Byte, t As Long, x As Long
Dim Outp As String For i = 0 To 255
S(i) = i
Next j = 1
For i = 0 To 255
If j > Len(key) Then j = 1
K(i) = Asc(Mid(key, j, 1))
j = j + 1
Next i j = 0
For i = 0 To 255
j = (j + S(i) + K(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
Next i i = 0
j = 0
For x = 1 To Len(inp)
i = (i + 1) Mod 256
j = (j + S(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
t = (S(i) + (S(j) Mod 256)) Mod 256
Y = S(t)
Outp = Outp & Chr(Asc(Mid(inp, x, 1)) Xor Y)
Next
RC4 = Outp
End Function
Dim temp As Single
Dim Char As String * 1
Dim XORMask As Single
Dim temp1 As Integer
Dim PasswordKey As String
PasswordKey = "MYLIVEFORAIUR"
Open LoadFilename For Binary As #1
Open LoadFilename For Binary As #2
For X = 1 To Len(PasswordKey)
temp = Asc(Mid$(PasswordKey, X, 1))
For Y = 1 To temp
temp1 = Rnd
Next Y
Randomize temp1
Next X
Counter = 0
For z = 1 To FileLen(LoadFilename)
XORMask = Int(Rnd * 256)
Get 1, , Char
Char = Chr$((Asc(Char) Xor XORMask))
Put 2, , Char
Counter = Counter + 1
If Counter > Len(PasswordKey) Then Counter = 1
For X = 1 To (Asc(Mid$(PasswordKey, Counter, 1)) * 2)
temp = Rnd
Next X
Next z
Close #1
Close #2
Dim temp As Single
Dim Char As String * 1
Dim XORMask As Single
Dim temp1 As Integer
Dim PasswordKey As String
PasswordKey = "MYLIVEFORAIUR"
Open SaveFilename For Binary As #1
Open SaveFilename For Binary As #2
For X = 1 To Len(PasswordKey)
temp = Asc(Mid$(PasswordKey, X, 1))
For Y = 1 To temp
temp1 = Rnd
Next Y
Randomize temp1
Next X
Counter = 0
For z = 1 To FileLen(SaveFilename)
XORMask = Int(Rnd * 256)
Get 1, , Char
Char = Chr$((Asc(Char) Xor XORMask))
Put 2, , Char
Counter = Counter + 1
If Counter > Len(PasswordKey) Then Counter = 1
For X = 1 To (Asc(Mid$(PasswordKey, Counter, 1)) * 2)
temp = Rnd
Next X
Next z
Close #1
Close #2
证，现在已经流行数字签名技术、公私密钥了，至于HASH摘要算法有那么多种要是自己写不
累死，CryptoAPI已经为我们考虑得很周到了，不过MSDN里的CryptoAPI都是用C做例子的
但是有大侠为我们把它们做到VB里了，大家一定要试试。Option Explicit' ***************************************************************************
' Module: clsCryptoAPI.cls
'
' Description: This module is used to make calls to the the advapi32.dll
' where the functions for CryptoAPI reside.
'
' Always give credit where credit is due. If you attach your
' creditials to a piece of code, you should be available to
' answer questions concerning that code.
'
' Thanks to: Phil Fresle http://www.frez.co.uk
' Found a lot of good code snippets at his site.
' Some you will recognize in this module.
' Kevin Matthew Goss
' His hashing routine pointed me in the right
' direction.
' Alex Rohr [email protected]
' Collected ideas from his file encryption class.
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 29-DEC-2000 Kenneth Ives [email protected]
' ***************************************************************************' ---------------------------------------------------------------------------
' Module level variables
' ---------------------------------------------------------------------------
Private m_lngCryptContext As Long
Private m_strPassword As String
Private m_strInputData As String
Private m_arOutputData() As Byte' ---------------------------------------------------------------------------
' Sample default passwords. These should be a mixture of letters and numbers
' at least twenty bytes long with both upper and lower case characters.
'
' KdrIVqo8qPaPQ80L82Yz PD1M5YvlJcH32bLvt1kj
' QNhcDVA8fwXx4Uz2Cl43 aJcuNL2XwKk6T0kq62cB <-- For this application
' qO38qluRW55mv8xOSBjW rAgPbgTpF17ITS46Phj1
' rI4zJ1GX4MicNkOg2rV0 s507v7QteKFHv4rOJehx
' jOsmwux8tIy1aN3Urq08 kK03QA7ycQxJ7V4BbvHK
' ---------------------------------------------------------------------------
Private Const DEFAULT_PASSWORD As String = "aJcuNL2XwKk6T0kq62cB"
Private Const HP_HASHVAL As Long = 2 ' Hash value
Private Const HP_HASHSIZE As Long = 4 ' Hash value size Private Const CRYPT_EXPORTABLE As Long = &H1&
Private Const CRYPT_USER_PROTECTED As Long = &H2&
Private Const CRYPT_CREATE_SALT As Long = &H4&
Private Const CRYPT_UPDATE_KEY As Long = &H8&
Private Const CRYPT_NO_SALT As Long = &H10&
Private Const CRYPT_PREGEN As Long = &H40&
Private Const CRYPT_RECIPIENT As Long = &H10&
Private Const CRYPT_INITIATOR As Long = &H40&
Private Const CRYPT_ONLINE As Long = &H80&
Private Const CRYPT_SF As Long = &H100&
Private Const CRYPT_CREATE_IV As Long = &H200&
Private Const CRYPT_KEK As Long = &H400&
Private Const CRYPT_DATA_KEY As Long = &H800&
Private Const CRYPT_OAEP As Long = &H40 ' used with RSA encryptions/decryptions
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const CRYPT_NEWKEYSET As Long = &H8&
Private Const CRYPT_DELETEKEYSET As Long = &H10&
Private Const CRYPT_MACHINE_KEYSET As Long = &H20& Private Const KP_IV As Long = 1 ' Initialization vector
Private Const KP_SALT As Long = 2 ' Salt value
Private Const KP_PADDING As Long = 3 ' Padding values
Private Const KP_MODE As Long = 4 ' Mode of the cipher
Private Const KP_MODE_BITS As Long = 5 ' Number of bits to feedback
Private Const KP_PERMISSIONS As Long = 6 ' Key permissions DWORD
Private Const KP_ALGID As Long = 7 ' Key algorithm
Private Const KP_BLOCKLEN As Long = 8 ' Block size of the cipher
Private Const KP_KEYLEN As Long = 9 ' Length of key in bits
Private Const KP_SALT_EX As Long = 10 ' Length of salt in bytes
Private Const KP_P As Long = 11 ' DSS/Diffie-Hellman P value
Private Const KP_G As Long = 12 ' DSS/Diffie-Hellman G value
Private Const KP_Q As Long = 13 ' DSS Q value
Private Const KP_X As Long = 14 ' Diffie-Hellman X value
Private Const KP_Y As Long = 15 ' Y value
Private Const KP_RA As Long = 16 ' Fortezza RA value
Private Const KP_RB As Long = 17 ' Fortezza RB value
Private Const KP_INFO As Long = 18 ' for putting information into an RSA envelope
Private Const KP_EFFECTIVE_KEYLEN As Long = 19 ' setting and getting RC2 effective key length
Private Const KP_SCHANNEL_ALG As Long = 20 ' for setting the Secure Channel algorithms
Private Const KP_CLIENT_RANDOM As Long = 21 ' for setting the Secure Channel client random data
Private Const KP_SERVER_RANDOM As Long = 22 ' for setting the Secure Channel server random data
Private Const KP_RP As Long = 23
Private Const KP_PRECOMP_MD5 As Long = 24
Private Const KP_PRECOMP_SHA As Long = 25
Private Const KP_CERTIFICATE As Long = 26 ' for setting Secure Channel certificate data (PCT1)
Private Const KP_CLEAR_KEY As Long = 27 ' for setting Secure Channel clear key data (PCT1)
Private Const KP_PUB_EX_LEN As Long = 28
Private Const KP_PUB_EX_VAL As Long = 29 Private Const SIMPLEBLOB As Long = 1
Private Const PUBLICKEYBLOB As Long = 6
Private Const PRIVATEKEYBLOB As Long = 7
Private Const PLAINTEXTKEYBLOB As Long = 8' ---------------------------------------------------------------------------
' CryptSetProvParam
' ---------------------------------------------------------------------------
Private Const PROV_RSA_FULL As Long = 1
Private Const PROV_RSA_SIG As Long = 2
Private Const PROV_DSS As Long = 3
Private Const PROV_FORTEZZA As Long = 4
Private Const PROV_MS_EXCHANGE As Long = 5
Private Const PROV_SSL As Long = 6
Private Const PROV_RSA_SCHANNEL As Long = 12
Private Const PROV_DSS_DH As Long = 13
Private Const PROV_EC_ECDSA_SIG As Long = 14
Private Const PROV_EC_ECNRA_SIG As Long = 15
Private Const PROV_EC_ECDSA_FULL As Long = 16
Private Const PROV_EC_ECNRA_FULL As Long = 17
Private Const PROV_SPYRUS_LYNKS As Long = 20' ---------------------------------------------------------------------------
' Algorithm classes
' ---------------------------------------------------------------------------
Private Const ALG_CLASS_ANY As Long = 0
Private Const ALG_CLASS_SIGNATURE As Long = 8192
Private Const ALG_CLASS_MSG_ENCRYPT As Long = 16384
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_CLASS_KEY_EXCHANGE As Long = 40960' ---------------------------------------------------------------------------
' Algorithm types
' ---------------------------------------------------------------------------
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_DSS As Long = 512
Private Const ALG_TYPE_RSA As Long = 1024
Private Const ALG_TYPE_BLOCK As Long = 1536
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_TYPE_DH As Long = 2560
Private Const ALG_TYPE_SECURECHANNEL As Long = 3072' ---------------------------------------------------------------------------
' Block cipher sub-ids
' ---------------------------------------------------------------------------
Private Const ALG_SID_RC2 As Long = 2' ---------------------------------------------------------------------------
' Stream cipher sub-ids
' ---------------------------------------------------------------------------
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_SEAL As Long = 2' ---------------------------------------------------------------------------
' Hash sub ids
' ---------------------------------------------------------------------------
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_SID_SHA As Long = 4
' ---------------------------------------------------------------------------
' Microsoft provider data (For the context)
' ---------------------------------------------------------------------------
Private Const MS_DEFAULT_PROVIDER As String = _
"Microsoft Base Cryptographic Provider v1.0"
Private Const MS_ENHANCED_PROVIDER As String = _
"Microsoft Enhanced Cryptographic Provider v1.0"
Private Const MS_DEF_RSA_SIG_PROV As String = _
"Microsoft RSA Signature Cryptographic Provider"
Private Const MS_DEF_RSA_SCHANNEL_PROV As String = _
"Microsoft Base RSA SChannel Cryptographic Provider"
Private Const MS_ENHANCED_RSA_SCHANNEL_PROV As String = _
"Microsoft Enhanced RSA SChannel Cryptographic Provider"
Private Const MS_DEF_DSS_PROV As String = _
"Microsoft Base DSS Cryptographic Provider"
Private Const MS_DEF_DSS_DH_PROV As String = _
"Microsoft Base DSS and Diffie-Hellman Cryptographic Provider"
' ---------------------------------------------------------------------------
' Error codes
' ---------------------------------------------------------------------------
Private Const ERR_CONTEXTOPEN As Long = 100
Private Const ERR_LOCKED As Long = 101
Private Const ERR_NOCONTEXT As Long = 102
Private Const ERR_KEYNOTVALID As Long = 103' ---------------------------------------------------------------------------
' Numbers defined by GetLastError
' ---------------------------------------------------------------------------
Private Const ERROR_BUSY As Long = 170
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_NOT_ENOUGH_MEMORY As Long = 8
Private Const ERROR_MORE_DATA As Long = 234
Private Const NTE_BAD_DATA As Long = &H80090005' ---------------------------------------------------------------------------
' Error messages
' ---------------------------------------------------------------------------
Private Const ERROR_AQUIRING_CONTEXT As String = "Could not acquire context"
Private Const ERROR_CREATING_HASH As String = "Could not create hash"
Private Const ERROR_CREATING_HASH_DATA As String = "Could not create hash data"
Private Const ERROR_DERIVING_KEY As String = "Could not derive key"
Private Const ERROR_ENCRYPTING_DATA As String = "Could not encrypt data"
Private Const ERROR_DECRYPTING_DATA As String = "Could not decrypt data"
Private Const ERROR_INVALID_HEX_STRING As String = "Not a valid hex string"
Private Const ERROR_MISSING_PARAMETER As String = "Both a string and a key are required"
Private Const ERROR_BAD_ENCRYPTION_TYPE As String = "Invalid encryption type specified"' ---------------------------------------------------------------------------
' Type of encryption to use
' ---------------------------------------------------------------------------
Private Const CALG_MD2 As Long = &H8001& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_MD2)
Private Const CALG_MD4 As Long = &H8002& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_MD4)
Private Const CALG_MD5 As Long = &H8003& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_MD5)
Private Const CALG_SHA As Long = &H8004& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_SHA)
Private Const CALG_SHA1 As Long = &H8004& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_SHA1)
Private Const CALG_MAC As Long = &H8005& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_MAC)
Private Const CALG_RSA_SIGN As Long = &H2400& ' (ALG_CLASS_SIGNATURE | ALG_TYPE_RSA | ALG_SID_RSA_ANY)
Private Const CALG_DSS_SIGN As Long = &H2200& ' (ALG_CLASS_SIGNATURE | ALG_TYPE_DSS | ALG_SID_DSS_ANY)
Private Const CALG_RSA_KEYX As Long = &HA400& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_RSA|ALG_SID_RSA_ANY)
Private Const CALG_DES As Long = &H6601& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_DES)
Private Const CALG_3DES_112 As Long = &H6609& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_3DES_112)
Private Const CALG_3DES As Long = &H6603& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_3DES)
Private Const CALG_RC2 As Long = &H6602& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_RC2)
Private Const CALG_RC4 As Long = &H6801& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_STREAM|ALG_SID_RC4)
Private Const CALG_SEAL As Long = &H6802& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_STREAM|ALG_SID_SEAL)
Private Const CALG_DH_SF As Long = &HAA01& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_DH|ALG_SID_DH_SANDF)
Private Const CALG_DH_EPHEM As Long = &HAA02& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_DH|ALG_SID_DH_EPHEM)
Private Const CALG_AGREEDKEY_ANY As Long = &HAA03& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_DH|ALG_SID_AGREED_KEY_ANY)
Private Const CALG_KEA_KEYX As Long = &HAA04& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_DH|ALG_SID_KEA)
Private Const CALG_HUGHES_MD5 As Long = &HA003& ' (ALG_CLASS_KEY_EXCHANGE|ALG_TYPE_ANY|ALG_SID_MD5)
Private Const CALG_SKIPJACK As Long = &H660A& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_SKIPJACK)
Private Const CALG_TEK As Long = &H660B& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_TEK)
Private Const CALG_CYLINK_MEK As Long = &H660C& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_CYLINK_MEK)
Private Const CALG_SSL3_SHAMD5 As Long = &H8008& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_SSL3SHAMD5)
Private Const CALG_SSL3_MASTER As Long = &H4D01& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_SSL3_MASTER)
Private Const CALG_SCHANNEL_MASTER_HASH As Long = &H4D02& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_SCHANNEL_MASTER_HASH)
Private Const CALG_SCHANNEL_MAC_KEY As Long = &H4D03& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_SCHANNEL_MAC_KEY)
Private Const CALG_SCHANNEL_ENC_KEY As Long = &H4D07& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_SCHANNEL_ENC_KEY)
Private Const CALG_PCT1_MASTER As Long = &H4D04& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_PCT1_MASTER)
Private Const CALG_SSL2_MASTER As Long = &H4D05& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_SSL2_MASTER)
Private Const CALG_TLS1_MASTER As Long = &H4D06& ' (ALG_CLASS_MSG_ENCRYPT|ALG_TYPE_SECURECHANNEL|ALG_SID_TLS1_MASTER)
Private Const CALG_RC5 As Long = &H660D& ' (ALG_CLASS_DATA_ENCRYPT|ALG_TYPE_BLOCK|ALG_SID_RC5)
Private Const CALG_HMAC As Long = &H8009& ' (ALG_CLASS_HASH | ALG_TYPE_ANY | ALG_SID_HMAC)' ---------------------------------------------------------------------------
' CryptoAPI API declares
' ---------------------------------------------------------------------------
Private Declare Function GetLastError Lib "kernel32" () As Long' CryptHashData has both string and byte versions
Private Declare Function CryptHashDataString Lib "advapi32.dll" _
Alias "CryptHashData" (ByVal hhash As Long, _
ByVal bData As String, ByVal dwDataLen As Long, _
ByVal dwFlags As Long) As Long Private Declare Function CryptHashDataBytes Lib "advapi32.dll" _
Alias "CryptHashData" (ByVal hhash As Long, _
bData As Byte, ByVal dwDataLen 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, _
ByRef 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 CryptSignHash Lib "advapi32.dll" _
Alias "CryptSignHashA" (ByVal hhash As Long, _
ByVal hkey As Long, ByVal Description As Long, _
ByVal dwFlags As Long, ByVal pData As Long, _
dwDataLength As Long) As Long Private Declare Function CryptVerifySignature Lib "advapi32.dll" _
Alias "CryptVerifySignatureA" (ByVal hhash As Long, _
ByVal pData As Long, ByVal datalength As Long, _
ByVal PublicKey As Long, ByVal Description As Long, _
ByVal dwFlags As Long) As Long Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
(ByVal hhash As Long, ByVal dwParam As Long, ByVal pbData As String, _
pdwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptGetHashParamSize Lib "advapi32.dll" _
Alias "CryptGetHashParam" (ByVal hhash As Long, _
ByVal dwParam As Long, pbData As Long, _
dwDataLength As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hhash 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 CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptGenRandom Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwLen As Long, _
ByVal pbBuffer As String) As Long Private Declare Function CryptGetUserKey Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwKeySpec As Long, _
phUserKey As Long) As Long Private Declare Function CryptGenKey Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal algid As Long, _
ByVal dwFlags As Long, phKey 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, _
ByRef phKey As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" _
(ByVal hkey As Long) As Long
Private Declare Function CryptGetKeyParam Lib "advapi32.dll" _
(ByVal hkey As Long, ByVal dwParam As Long, _
ByVal pbData As Long, pdwDataLen As Long, _
ByVal dwFlags As Long) As Long Private Declare Function CryptSetKeyParam Lib "advapi32.dll" _
(ByVal hkey As Long, ByVal dwParam As Long, _
ByVal pbData As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptExportKey Lib "advapi32.dll" _
(ByVal hkey As Long, ByVal hExpKey As Long, _
ByVal dwBlobType As Long, ByVal dwFlags As Long, _
ByVal pbData As Long, pdwDataLen As Long) As Long Private Declare Function CryptImportKey Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal pbData As Long, _
ByVal dwDataLength As Long, ByVal hPubKey As Long, _
ByVal dwFlags As Long, pKeyval 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, _
ByRef 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, ByRef pdwDataLen As Long) As Long
Private Declare Function CryptGetProvParamString Lib "advapi32.dll" _
Alias "CryptGetProvParam" (ByVal hProv As Long, _
ByVal dwParam As Long, ByVal pbData As String, _
pdwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptGetProvParam Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwParam As Long, _
pbData As Any, pdwDataLen As Long, _
ByVal dwFlags As Long) As Long
' ***************************************************************************
' Property area
' ***************************************************************************
Public Property Let InputData(arInData() As Byte)' ---------------------------------------------------------------------------
' Input data only in byte array
' ---------------------------------------------------------------------------
m_strInputData = ByteArrayToString(arInData())End PropertyPublic Property Get OutputData() As Byte()
' ---------------------------------------------------------------------------
' Output data only in byte array
' ---------------------------------------------------------------------------
OutputData = m_arOutputDataEnd PropertyPublic Property Let Password(arPWord() As Byte)
' ---------------------------------------------------------------------------
' Password is input data only.
' if no password is provided then use the default password.
' ---------------------------------------------------------------------------
If arPWord(0) = 0 And UBound(arPWord) = 0 Then
m_strPassword = DEFAULT_PASSWORD
Else
m_strPassword = ByteArrayToString(arPWord())
End If
End Property' ***************************************************************************
' Functions and Procedures
' ***************************************************************************
Public Function ByteArrayToString(arByte() As Byte) As String' ***************************************************************************
' Routine: ByteArrayToString
'
' Description: Convert the byte array data into long integers for the
' Word() array
'
' Parameters: arByte() - Incoming data in byte format
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 03-OCT-2000 Kenneth Ives [email protected]
' Modified and documented
' 20-JAN-2001 VB2-The-Max http://www.vb2themax.com/
' From an article titled "10 Hot Tips from VB-2-the-Max"
' by Francesco Balena
' This is tip no.9 on faster string concatenation with a little
' modification.
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define variables
' ---------------------------------------------------------------------------
Dim lngLoop As Long
Dim lngIndex As Long
Dim lngLength As Long
Dim lngPaddingLen As Long
Dim lngMax As Long
Dim strTmp As String
Dim strOutput As String
Const ADD_SPACES As Long = 10000
' ---------------------------------------------------------------------------
' Determine amount of data in the byte array.
' ---------------------------------------------------------------------------
strTmp = ""
lngIndex = 1 ' index pointer for output string
lngMax = UBound(arByte) ' determine number of elements in array
lngPaddingLen = (ADD_SPACES * 9) ' 90000 blank spaces
strOutput = Space$(lngPaddingLen) ' preload output string
' ---------------------------------------------------------------------------
' Unload the byte array and convert each character back to its ASCII
' character value
' ---------------------------------------------------------------------------
For lngLoop = 0 To lngMax - 1
strTmp = Chr(arByte(lngLoop)) ' Convert each byte to an ASCII character
lngLength = Len(strTmp) ' save the length of the converted data
' see if some more padding has to be added to the output string
If (lngIndex + lngLength) >= lngPaddingLen Then
lngPaddingLen = lngPaddingLen + ADD_SPACES ' boost blank space counter
strOutput = strOutput & Space$(ADD_SPACES) ' append some blank spaces
End If
Mid$(strOutput, lngIndex, lngLength) = strTmp ' insert data into output string
lngIndex = lngIndex + lngLength ' increment output string pointer
Next
' ---------------------------------------------------------------------------
' Return the string data
' ---------------------------------------------------------------------------
strOutput = Left$(strOutput, lngIndex - 1) ' remove trailing blanks
ByteArrayToString = strOutput ' return data string
End FunctionPublic Function ConvertStringFromHex(ByVal strHex As String) As String' ***************************************************************************
' Routine: ConvertStringFromHex
'
' Description: Take two characters at a time and convert to its ASCII
' decimal value.
'
' Parameters: strHex - Data to be converted
'
' Returns: data string in ASCII decimal format
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 15-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' 20-JAN-2001 VB2-The-Max http://www.vb2themax.com/
' From an article titled "10 Hot Tips from VB-2-the-Max"
' by Francesco Balena
' This is tip no.9 on faster string concatenation with a little
' modification.
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define variables
' ---------------------------------------------------------------------------
Dim lngLoop As Long
Dim lngIndex As Long
Dim lngLength As Long
Dim lngPaddingLen As Long
Dim lngMax As Long
Dim strTmp As String
Dim strOutput As String
Const ADD_SPACES As Long = 10000' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
strTmp = ""
lngIndex = 1 ' index pointer for output string
lngMax = Len(strHex) ' length of input hex string
lngPaddingLen = (ADD_SPACES * 9) ' 90000 blank spaces
strOutput = Space$(lngPaddingLen) ' preload output string
' ---------------------------------------------------------------------------
' See if the hex data string can be divided evenly by two. If not, then the
' data is corrupted.
' ---------------------------------------------------------------------------
If lngMax Mod 2 <> 0 Then
MsgBox "Data string is corrupted. Cannot be Decrypted.", _
vbCritical + vbOKOnly, "Data corrupted"
Exit Function
End If
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
For lngLoop = 1 To lngMax Step 2
strTmp = Chr(Val("&H" & Mid$(strHex, lngLoop, 2)))
lngLength = Len(strTmp) ' save the length of the converted data
' see if some more padding has to be added to the output string
If (lngIndex + lngLength) >= lngPaddingLen Then
lngPaddingLen = lngPaddingLen + ADD_SPACES ' boost blank space counter
strOutput = strOutput & Space$(ADD_SPACES) ' append some blank spaces
End If
Mid$(strOutput, lngIndex, lngLength) = strTmp ' insert data into output string
lngIndex = lngIndex + lngLength ' increment output string pointer
Next
' ---------------------------------------------------------------------------
' Return the formatted data
' ---------------------------------------------------------------------------
strOutput = Left$(strOutput, lngIndex - 1) ' remove trailing blanks
ConvertStringFromHex = strOutput ' return data stringEnd FunctionPublic Function ConvertStringToHex(ByVal strInput As String, _
Optional blnRetUppercase As Boolean = True) As String
' ***************************************************************************
' Routine: ConvertStringToHex
'
' Description: Take one character at a time and convert first to an
' integer then to hex. Prefix with two zeros in case the
' result is 0x00 to 0x0F (leading zeros tend to disappear).
' Then capture the last two characters. This will give a
' good two character hex display.
'
' Parameters: strInput - Data to be converted
' blnRetUppercase - Optional [Default] - TRUE
' else FALSE
'
' Returns: hex data string in uppercase
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 15-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' 20-JAN-2001 VB2-The-Max http://www.vb2themax.com/
' From an article titled "10 Hot Tips from VB-2-the-Max"
' by Francesco Balena
' This is tip no.9 on faster string concatenation with a little
' modification.
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define variables
' ---------------------------------------------------------------------------
Dim lngLoop As Long
Dim lngIndex As Long
Dim lngLength As Long
Dim lngPaddingLen As Long
Dim lngMax As Long
Dim strTmp As String
Dim strOutput As String
Const ADD_SPACES As Long = 10000' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
strTmp = ""
lngIndex = 1 ' index pointer for output string
lngMax = Len(strInput) ' length of input data string
lngPaddingLen = (ADD_SPACES * 9) ' 90000 blank spaces
strOutput = Space$(lngPaddingLen) ' preload output string
' ---------------------------------------------------------------------------
' Convert to hex
' ---------------------------------------------------------------------------
For lngLoop = 1 To lngMax
strTmp = Right$("00" & Hex(Asc(Mid$(strInput, lngLoop, 1))), 2)
lngLength = Len(strTmp) ' save the length of the converted data
' see if some more padding has to be added to the output string
If (lngIndex + lngLength) >= lngPaddingLen Then
lngPaddingLen = lngPaddingLen + ADD_SPACES ' boost blank space counter
strOutput = strOutput & Space$(ADD_SPACES) ' append some blank spaces
End If
Mid$(strOutput, lngIndex, lngLength) = strTmp ' insert data into output string
lngIndex = lngIndex + lngLength ' increment output string pointer
Next
' ---------------------------------------------------------------------------
' remove trailing blanks
' ---------------------------------------------------------------------------
strOutput = Left$(strOutput, lngIndex - 1)
' ---------------------------------------------------------------------------
' Return hex string
' ---------------------------------------------------------------------------
If blnRetUppercase Then
ConvertStringToHex = StrConv(strOutput, vbUpperCase)
Else
ConvertStringToHex = strOutput
End If
End FunctionPublic Function CreateHash(ByVal strInText As String, _
Optional ByVal intHashType As Integer = 2, _
Optional ByVal blnConvertToHex As Boolean = True, _
Optional ByVal blnAppendPasskey As Boolean = False, _
Optional ByVal blnCaseSensitive As Boolean = False) As String' ***************************************************************************
' Routine: CreateHash
'
' Description: This code shows how to generate a hash of a string of data.
' There are 4 algorithms available in this version:
' MD2, MD4, MD5, and SHA-1.
'
' Hashes are extremely usefull for determining whether a
' transmission or file has been altered. The MDn returns a
' 16 character hash and the SHA returns a 20 character hash.
' No two hashes are alike unless the string matches perfectly,
' whether binary data or a text string. I use hashes to
' create crypto keys and to verify integrity of packets when
' using winsock (UDP especially). Be aware that if you choose
' to not convert the return data to hex, then hashes may not
' store to text correctly because of the possible existence of
' non printable characters in the stream.
'
' Parameters: strInText - string of data to get hash of
' intHashType - Numeric identifier for the type of hash
' blnConvertToHex - TRUE/FALSE
' True (Default) - Convert return data to Hex
' False - Do not convert the return data
' blnAppendPasskey - TRUE/FALSE
' True - Append the default password to data to
' be hashed
' False (Default) - Do not append the password to
' the data to be hashed
' blnCaseSensitive - TRUE/FALSE (only recognized if
' blnConvertToHex = TRUE)
' True - Return data as it was created, upper and
' lower case
' False (Default) - Return the data in uppercase
'
' Returns: ASCII string of characters
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 01-DEC-2000 Kevin Matthew Goss
' Wrote routine
' 15-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim lngHashType As Long
Dim lngOutputLength As Long
Dim lngHandle As Long
Dim lngIndex As Long
Dim strTmpHash As String
' ---------------------------------------------------------------------------
' Append passkey to data to be hashed
' ---------------------------------------------------------------------------
If blnAppendPasskey Then
strInText = strInText & DEFAULT_PASSWORD
End If
' ---------------------------------------------------------------------------
' Determine type of hash algorithm to use
' ---------------------------------------------------------------------------
Select Case intHashType
Case 0 ' use MD2 algorithm creates a 128-bit output
lngHashType = CALG_MD2
lngOutputLength = 16
Case 1 ' use MD4 algorithm creates a 128-bit output
lngHashType = CALG_MD4
lngOutputLength = 16
Case 2 ' use MD5 algorithm creates a 128-bit output [Default]
lngHashType = CALG_MD5
lngOutputLength = 16
Case 3 ' use SHA-1 algorithm creates a 160-bit output
lngHashType = CALG_SHA
lngOutputLength = 20
Case Else
CreateHash = ""
Exit Function
End Select' ---------------------------------------------------------------------------
' Initialize variables. Some API functions do not work and play well with
' string buffers that are filled with String$() or Nulls. I do not know why.
' Since I started using Space$() to preload a buffer string, I have had no
' problems.
' ---------------------------------------------------------------------------
strTmpHash = Space$(lngOutputLength)' ---------------------------------------------------------------------------
' The CryptCreateHash function initiates the hashing of a stream of data. It
' creates and returns to the calling application a handle to a CSP hash
' object. This handle is used in subsequent calls to CryptHashData to hash
' session keys and other streams of data.
' ---------------------------------------------------------------------------
If Not CBool(CryptCreateHash(m_lngCryptContext, lngHashType, 0, 0, lngHandle)) Then
CreateHash = ""
Exit Function
End If' ---------------------------------------------------------------------------
' The CryptHashData function adds data to a specified hash object. This
' function can be called multiple times to compute the hash of long or
' discontinuous data streams.
' ---------------------------------------------------------------------------
If Not CBool(CryptHashData(lngHandle, strInText, Len(strInText), 0)) Then
CreateHash = ""
Exit Function
End If' ---------------------------------------------------------------------------
' The CryptGetHashParam function retrieves data that governs the operations
' of a hash object. The actual hash value can be retrieved by using this
' function.
' ---------------------------------------------------------------------------
If Not CBool(CryptGetHashParam(lngHandle, HP_HASHVAL, strTmpHash, lngOutputLength, 0)) Then
CreateHash = ""
Exit Function
End If
' ---------------------------------------------------------------------------
' See if we are to return the data in Hex or Binary format
' ---------------------------------------------------------------------------
If blnConvertToHex Then
' convert to hex format
If blnCaseSensitive Then
CreateHash = ConvertStringToHex(strTmpHash, False)
Else
CreateHash = ConvertStringToHex(strTmpHash, True)
End If
Else
' Return the raw data in binary format
CreateHash = strTmpHash
End If
End Function
Public Function CreateRandom(Optional lngDataLength As Long = 1024, _
Optional blnConvertToHex As Boolean = False, _
Optional blnRetExactLength As Boolean = False) As String' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim strTmp As String
Dim strRndBuffer As String
Dim lngIndex As Long
' ---------------------------------------------------------------------------
' Initialize variables. Some API functions do not work and play well with
' string buffers that are filled with String$() or Nulls. I do not know why.
' Since I started using Space$() to preload a buffer string, I have had no
' problems.
' ---------------------------------------------------------------------------
strTmp = ""
strRndBuffer = Space$(lngDataLength)' ---------------------------------------------------------------------------
' Create the random data
' ---------------------------------------------------------------------------
If Not CBool(CryptGenRandom(m_lngCryptContext, lngDataLength, strRndBuffer)) Then
CreateRandom = ""
Exit Function
End If
' ---------------------------------------------------------------------------
' Retrun the random data string
' ---------------------------------------------------------------------------
If blnConvertToHex Then
' convert data string to hex
strTmp = ConvertStringToHex(strRndBuffer)
' if the user wants an exact length of data return then
' return just what was requested; otherwise, return the
' full data string convert to hex. This means that the
' data string has now doubled in length.
If blnRetExactLength Then
CreateRandom = Left$(strTmp, lngDataLength)
Else
CreateRandom = strTmp
End If
Else
' do not convert to hex prior to returning the data string
CreateRandom = strRndBuffer
End IfEnd Function
Public Function CreateSaltData(lngReturnLength As Long) As String
' ***************************************************************************
' Routine: CreateSaltData
'
' Description: This code allows the user to get truly random data from the
' advapi32 library. It demonstrates on how to acquire a
' context in the CryptoAPI and get random data at a user
' defined length. This data uses all ASCII characters and looks
' itself like an encrypted mess. I use this function to pad
' encrypted files and transmissions to mask them even further
' and also to pad passwords and make them a lot more secure.
'
' Parameters: lngReturnLength - Length of data to be returned
'
' Returns: A string of random data
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 01-DEC-2000 Kevin Matthew Goss
' Routine created
' 03-OCT-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim strTmpData As String' ---------------------------------------------------------------------------
' Make sure a value greater than zero was passed
' ---------------------------------------------------------------------------
If lngReturnLength <= 0 Then
CreateSaltData = ""
Exit Function
End If' ---------------------------------------------------------------------------
' Initialize variables. Some API functions do not work and play well with
' string buffers that are filled with String$() or Nulls. I do not know why.
' Since I started using Space$() to preload a buffer string, I have had no
' problems.
' ---------------------------------------------------------------------------
strTmpData = Space$(lngReturnLength)
' ---------------------------------------------------------------------------
' Create the random generated salt data
' ---------------------------------------------------------------------------
If Not CBool(CryptGenRandom(m_lngCryptContext, lngReturnLength, strTmpData)) Then
CreateSaltData = ""
Else
CreateSaltData = strTmpData
End IfEnd FunctionPublic Function CreateSaltValue(lngReturnLength As Long) As String' ***************************************************************************
' Routine: CreateSaltValue
'
' Description: This code allows the user to get generate random data. It
' will return only values 0-9, A-Z, and a-z
'
' Parameters: lngReturnLength - Length of data to be returned
'
' Returns: A string of random data
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 03-OCT-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim intChar As Integer
Dim lngIndex As Long
Dim strSalt As String
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
strSalt = ""
' ---------------------------------------------------------------------------
' Create salt value string using 0-9, A-Z, a-z only
' ---------------------------------------------------------------------------
For lngIndex = 1 To lngReturnLength
intChar = Int(Rnd2(48, 122)) ' Create value 48 to 122
Select Case intChar
Case 58 To 64, 91 To 96
' if value returned is not acceptable then
' add 7 to fall within our ranges
intChar = intChar + 7
End Select
strSalt = strSalt & Chr(intChar) ' append to output string
Next' ---------------------------------------------------------------------------
' Return the new Salt value
' ---------------------------------------------------------------------------
CreateSaltValue = strSalt
End FunctionPrivate Sub CryptoDecrypt()' ***************************************************************************
' Routine: CryptoDecrypt
'
' DestrCription: Perform the actual decryption.
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 00-Feb-1998 Sam Patterson's COMponent builder Article in Visual Basic
' Programmers Journal, "Secure Your Apps with CryptoAPI".
' Great magazine to subscribe to.
' 29-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim lngHHash As Long ' Hash handle
Dim lngHkey As Long
Dim lngRetCode As Long ' return value from an API call
Dim lngHExchgKey As Long
Dim lngCryptLength As Long
Dim lngCryptBufLen As Long
Dim strCryptBuffer As String
Dim strOutputData As String
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
strOutputData = ""
strCryptBuffer = ""
Erase m_arOutputData() ' empty array
ReDim m_arOutputData(0) ' resize to smallest number of elements
On Error GoTo CryptoDecrypt_Error
' ---------------------------------------------------------------------------
' Create a hash object using MD5
' ---------------------------------------------------------------------------
If Not CBool(CryptCreateHash(m_lngCryptContext, CALG_MD5, 0, 0, lngHHash)) Then
MsgBox "Error: " & CStr(GetLastError) & " during CryptCreateHash!", _
vbExclamation + vbOKOnly, "Decryption Errors"
GoTo CleanUp
End If' ---------------------------------------------------------------------------
' Hash in the password text
' ---------------------------------------------------------------------------
If Not CBool(CryptHashData(lngHHash, m_strPassword, Len(m_strPassword), 0)) Then
MsgBox "Error: " & CStr(GetLastError) & " during CryptHashData!", _
vbExclamation + vbOKOnly, "Decryption Errors"
GoTo CleanUp
End If
' ---------------------------------------------------------------------------
' Create a session key from the hash object using RC4
' ---------------------------------------------------------------------------
If Not CBool(CryptDeriveKey(m_lngCryptContext, CALG_RC4, lngHHash, 0, lngHkey)) Then
MsgBox ("Error: " & CStr(GetLastError) & " during CryptDeriveKey!")
GoTo CleanUp
End If' ---------------------------------------------------------------------------
' Destroy the hash object.
' ---------------------------------------------------------------------------
lngRetCode = CryptDestroyHash(lngHHash)
lngHHash = 0' ---------------------------------------------------------------------------
' Prepare strCryptBuffer for CryptDecrypt.
' Initialize variables. Some API functions do not work and play well with
' string buffers that are filled with String$() or Nulls. I do not know why.
' Since I started using Space$() to preload a buffer string, I have had no
' problems.
' ---------------------------------------------------------------------------
lngCryptBufLen = Len(m_strInputData) * 2
strCryptBuffer = m_strInputData
strCryptBuffer = Space$(lngCryptBufLen)
Mid$(strCryptBuffer, 1, Len(m_strInputData)) = m_strInputData' ---------------------------------------------------------------------------
' Decrypt the text data
' ---------------------------------------------------------------------------
If Not CBool(CryptDecrypt(lngHkey, 0, 1, 0, strCryptBuffer, lngCryptBufLen)) Then
MsgBox "Bytes required:" & CStr(lngCryptBufLen) & vbCrLf & vbCrLf & _
"Error " & CStr(GetLastError) & " during CryptDecrypt!", _
vbExclamation + vbOKOnly, "Decryption Errors"
GoTo CleanUp
End If' ---------------------------------------------------------------------------
' Return the decrypted data string in a byte array.
' ---------------------------------------------------------------------------
strOutputData = Left$(strCryptBuffer, Len(m_strInputData))
m_arOutputData = StringToByteArray(strOutputData)CleanUp:
' ---------------------------------------------------------------------------
' Destroy session key.
' ---------------------------------------------------------------------------
If (lngHkey) Then
lngRetCode = CryptDestroyKey(lngHkey)
End If
' ---------------------------------------------------------------------------
' Destroy key exchange key handle
' ---------------------------------------------------------------------------
If lngHExchgKey Then
lngRetCode = CryptDestroyKey(lngHExchgKey)
End If
' ---------------------------------------------------------------------------
' Destroy hash object
' ---------------------------------------------------------------------------
If lngHHash Then
lngRetCode = CryptDestroyHash(lngHHash)
End If Exit SubCryptoDecrypt_Error:
' ---------------------------------------------------------------------------
' An error ocurred during the decryption process
' ---------------------------------------------------------------------------
MsgBox "Error: " & CStr(Err.Number) & " " & Err.Description & vbCrLf & _
vbCrLf & "A critical error ocurred during the decryption process.", _
vbCritical + vbOKOnly, "Decryption Errors" GoTo CleanUpEnd Sub
Private Sub CryptoEncrypt()' ***************************************************************************
' Routine: CryptoEncrypt
'
' Description: Encrypting files with the CryptoAPI is a four-step process.
' First, select a CSP to handle the encryption. Second, create
' a hash object, and base that hash object around the password
' data. Third, create a key object based on this hash.
' Finally, use a key to encrypt the data.
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 00-Feb-1998 Sam Patterson's COMponent builder Article in Visual Basic
' Programmers Journal, "Secure Your Apps with CryptoAPI".
' Great magazine to subscribe to.
' 29-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim lngHHash As Long ' Hash handle
Dim lngHkey As Long
Dim lngRetCode As Long ' return value from an API call
Dim lngHExchgKey As Long
Dim lngCryptLength As Long
Dim lngCryptBufLen As Long
Dim strCryptBuffer As String
Dim strOutputData As String
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
strOutputData = ""
strCryptBuffer = ""
Erase m_arOutputData()
On Error GoTo CryptoEncrypt_Error
' ---------------------------------------------------------------------------
' Create a hash object using MD5
' ---------------------------------------------------------------------------
If Not CBool(CryptCreateHash(m_lngCryptContext, CALG_MD5, 0, 0, lngHHash)) Then
MsgBox "Error: " & CStr(GetLastError) & " during CryptCreateHash!", _
vbExclamation + vbOKOnly, "Encryption Errors"
GoTo CleanUp
End If
' ---------------------------------------------------------------------------
' Hash in the password text
' ---------------------------------------------------------------------------
If Not CBool(CryptHashData(lngHHash, m_strPassword, Len(m_strPassword), 0)) Then
MsgBox "Error: " & CStr(GetLastError) & " during CryptHashData!", _
vbExclamation + vbOKOnly, "Encryption Errors"
GoTo CleanUp
End If
' ---------------------------------------------------------------------------
' Create a session key from the hash object using RC4
' ---------------------------------------------------------------------------
If Not CBool(CryptDeriveKey(m_lngCryptContext, CALG_RC4, lngHHash, 0, lngHkey)) Then
MsgBox "Error: " & CStr(GetLastError) & " during CryptDeriveKey!", _
vbExclamation + vbOKOnly, "Encryption Errors"
GoTo CleanUp
End If' ---------------------------------------------------------------------------
' Destroy the hash object.
' ---------------------------------------------------------------------------
lngRetCode = CryptDestroyHash(lngHHash)
lngHHash = 0' ---------------------------------------------------------------------------
' Initialize variables. Some API functions do not work and play well with
' string buffers that are filled with String$() or Nulls. I do not know why.
' Since I started using Space$() to preload a buffer string, I have had no
' problems.
' ---------------------------------------------------------------------------
lngCryptLength = Len(m_strInputData)
lngCryptBufLen = lngCryptLength * 2
strCryptBuffer = Space$(lngCryptBufLen)
Mid$(strCryptBuffer, 1, Len(m_strInputData)) = m_strInputData' ---------------------------------------------------------------------------
' Encrypt the text data
' ---------------------------------------------------------------------------
If Not CBool(CryptEncrypt(lngHkey, 0, 1, 0, strCryptBuffer, lngCryptLength, lngCryptBufLen)) Then
MsgBox "Bytes required:" & CStr(lngCryptBufLen) & vbCrLf & vbCrLf & _
"Error: " & CStr(GetLastError) & " during CryptEncrypt!", _
vbExclamation + vbOKOnly, "Encryption Errors"
End If' ---------------------------------------------------------------------------
' Return the encrypted data string in a byte array
' ---------------------------------------------------------------------------
strOutputData = Left$(strCryptBuffer, lngCryptLength)
m_arOutputData = StringToByteArray(strOutputData)
CleanUp:
' ---------------------------------------------------------------------------
' Destroy session key.
' ---------------------------------------------------------------------------
If (lngHkey) Then
lngRetCode = CryptDestroyKey(lngHkey)
End If
' ---------------------------------------------------------------------------
' Destroy key exchange key handle
' ---------------------------------------------------------------------------
If lngHExchgKey Then
lngRetCode = CryptDestroyKey(lngHExchgKey)
End If
' ---------------------------------------------------------------------------
' Destroy hash object
' ---------------------------------------------------------------------------
If lngHHash Then
lngRetCode = CryptDestroyHash(lngHHash)
End If
Exit SubCryptoEncrypt_Error:
' ---------------------------------------------------------------------------
' An error ocurred during the encryption process
' ---------------------------------------------------------------------------
MsgBox "Error: " & CStr(Err.Number) & " " & Err.Description & vbCrLf & _
vbCrLf & "A critical error ocurred during the encryption process.", _
vbCritical + vbOKOnly, "Encryption Error" GoTo CleanUpEnd Sub
Public Sub Decrypt()' ***************************************************************************
' Routine: Decrypt
'
' Description: Call the decyption routine.
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 00-Feb-1998 Sam Patterson's COMponent builder Article in Visual Basic
' Programmers Journal, "Secure Your Apps with CryptoAPI".
' Great magazine to subscribe to.
' 29-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
Call CryptoDecryptEnd SubPublic Sub Encrypt()' ***************************************************************************
' Routine: Encrypt
'
' Description: Encrypting files with the CryptoAPI is a four-step process.
' First, select a CSP to handle the encryption. Second, create
' a hash object, and base that hash object around the password
' data. Third, create a key object based on this hash.
' Finally, use a key to encrypt the data.
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 00-Feb-1998 Sam Patterson's COMponent builder Article in Visual Basic
' Programmers Journal, "Secure Your Apps with CryptoAPI".
' Great magazine to subscribe to.
' 29-DEC-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
Call CryptoEncrypt
End SubPublic Function StringToByteArray(varInput As Variant) As Byte()' ***************************************************************************
' Routine: StringToByteArray
'
' Description: converts a string of data into a byte array [Range 0, 255]
'
' Parameters: strInput - data string to be converted into a byte array
'
' Returns: Byte array
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 03-OCT-2000 Kenneth Ives [email protected]
' Modified and documented
' ***************************************************************************
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim lngIndex As Long
Dim lngLength As Long
Dim bytBuffer() As Byte
' ---------------------------------------------------------------------------
' Store length of data string in a variable. Speeds up the process by not
' having to constantly evaluate the string length. Works great with loops
' and long strings of data. Good habit to get into.
' ---------------------------------------------------------------------------
lngLength = Len(varInput)
If lngLength < 1 Then
ReDim bytBuffer(0)
GoTo CleanUp
End If
' ---------------------------------------------------------------------------
' Resize the array based on length on input string
' ---------------------------------------------------------------------------
ReDim bytBuffer(lngLength)
' ---------------------------------------------------------------------------
' Convert each character in the data string to its ASCII numeric equivalent.
' I use the VB function CByte() because sometimes the ASC() function returns
' data that does not convert to a value of 0 to 255 cleanly.
' ---------------------------------------------------------------------------
For lngIndex = 0 To lngLength - 1
bytBuffer(lngIndex) = Asc(Mid$(varInput, lngIndex + 1, 1))
Next
CleanUp:
' ---------------------------------------------------------------------------
' Return the byte array
' ---------------------------------------------------------------------------
StringToByteArray = bytBuffer
End FunctionPrivate Function Initialize_CryptoAPI() As Boolean
On Error Resume Next
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
Dim strTmp As String
Dim strProvider1 As String
Dim strProvider2 As String
Dim strErrorMsg As String
' ---------------------------------------------------------------------------
' Prepare string buffers
' ---------------------------------------------------------------------------
strTmp = ""
strProvider1 = MS_ENHANCED_PROVIDER & vbNullChar
strProvider2 = MS_DEFAULT_PROVIDER & vbNullChar
' ---------------------------------------------------------------------------
' Gain Access To CryptoAPI. This is just a demo of how to get access to the
' 128-bit provider. If you are not sure that everyone is using the 128-bit
' version then comment out this first "IF" statement completely. The default
' will work just as well.
' ---------------------------------------------------------------------------
' Attempt to acquire a handle to the ENHANCED (128-bit) key container.
If CBool