A Class that wrap around crypto API for encrypting and hashing file or data.
Usage Example:
Sub test()
Dim cc As CCrypt
Set cc = New CCrypt
cc.EncryptFile CALG_3DES, "c:\windows\system32\notepad.exe", "c:\encrypted.dat", "pwd"
cc.DecryptFile CALG_3DES, "c:\encrypted.dat", "c:\decrypted.exe", "pwd"
Debug.Print "Notepad.Exe MD5: " & cc.HashFile("c:\windows\system32\notepad.exe", CALG_MD5) & vbCrLf & _
"Encrypted.dat MD5: " & cc.HashFile("c:\encrypted.dat", CALG_MD5) & vbCrLf & _
"Decrypted.exe MD5: " & cc.HashFile("c:\decrypted.exe", CALG_MD5)
Set cc = Nothing
End SubSample Output:
Notepad.Exe MD5: DAF60E13E96ECB67F0EDAA89C6B01B8D Encrypted.dat MD5: C7443A42B7B69A5ABD6AF889CF4E4F36 Decrypted.exe MD5: DAF60E13E96ECB67F0EDAA89C6B01B8D
Code:
'15:51 24/11/2010 Simplify HashString/HashBytes to HashData, Encrypt/Decrypt String/Bytes to EncryptData/DecryptData
'14:15 05/11/2010 Add EncryptBytes & DecryptBytes
'21:44 17/10/2010 Purpose: Wrap CryptoAPI for authentication, encoding, and encryption
'
'Reference : http://msdn.microsoft.com/en-us/library/aa382375%28VS.85%29.aspx
' http://msdn.microsoft.com/en-us/library/ms867086.aspx
'
'Copyright © 2010 RENO
Option Compare Text
Option Explicit
Private Const ALG_CLASS_ANY As Long = 0
Private Const ALG_CLASS_SIGNATURE As Long = (1 * 2 ^ 13)
Private Const ALG_CLASS_MSG_ENCRYPT As Long = (2 * 2 ^ 13)
Private Const ALG_CLASS_DATA_ENCRYPT As Long = (3 * 2 ^ 13)
Private Const ALG_CLASS_HASH As Long = (4 * 2 ^ 13)
Private Const ALG_CLASS_KEY_EXCHANGE As Long = (5 * 2 ^ 13)
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_DSS As Long = (1 * 2 ^ 9)
Private Const ALG_TYPE_RSA As Long = (2 * 2 ^ 9)
Private Const ALG_TYPE_BLOCK As Long = (3 * 2 ^ 9)
Private Const ALG_TYPE_STREAM As Long = (4 * 2 ^ 9)
Private Const ALG_TYPE_DH As Long = (5 * 2 ^ 9)
Private Const ALG_TYPE_SECURECHANNEL As Long = (6 * 2 ^ 9)
Private Const ALG_SID_ANY As Long = 0
Private Const ALG_SID_3DES As Long = 3
Private Const ALG_SID_3DES_112 As Long = 9
Private Const ALG_SID_AGREED_KEY_ANY As Long = 3
Private Const ALG_SID_CAST As Long = 6
Private Const ALG_SID_CYLINK_MEK As Long = 12
Private Const ALG_SID_DES As Long = 1
Private Const ALG_SID_DESX As Long = 4
Private Const ALG_SID_DH_EPHEM As Long = 2
Private Const ALG_SID_DH_SANDF As Long = 1
Private Const ALG_SID_DSS_ANY As Long = 0
Private Const ALG_SID_DSS_DMS As Long = 2
Private Const ALG_SID_DSS_PKCS As Long = 1
Private Const ALG_SID_EXAMPLE As Long = 80
Private Const ALG_SID_HMAC As Long = 9
Private Const ALG_SID_IDEA As Long = 5
Private Const ALG_SID_KEA As Long = 4
Private Const ALG_SID_MAC As Long = 5
Private Const ALG_SID_MD2 As Long = 1
Private Const ALG_SID_MD4 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_SID_PCT1_MASTER As Long = 4
Private Const ALG_SID_RC2 As Long = 2
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_RC5 As Long = 13
Private Const ALG_SID_RIPEMD As Long = 6
Private Const ALG_SID_RIPEMD160 As Long = 7
Private Const ALG_SID_RSA_ANY As Long = 0
Private Const ALG_SID_RSA_ENTRUST As Long = 3
Private Const ALG_SID_RSA_MSATWORK As Long = 2
Private Const ALG_SID_RSA_PGP As Long = 4
Private Const ALG_SID_SAFERSK128 As Long = 8
Private Const ALG_SID_SAFERSK64 As Long = 7
Private Const ALG_SID_SCHANNEL_ENC_KEY As Long = 7
Private Const ALG_SID_SCHANNEL_MAC_KEY As Long = 3
Private Const ALG_SID_SCHANNEL_MASTER_HASH As Long = 2
Private Const ALG_SID_SEAL As Long = 2
Private Const ALG_SID_SHA As Long = 4
Private Const ALG_SID_SHA1 As Long = 4
Private Const ALG_SID_SKIPJACK As Long = 10
Private Const ALG_SID_SSL2_MASTER As Long = 5
Private Const ALG_SID_SSL3_MASTER As Long = 1
Private Const ALG_SID_SSL3SHAMD5 As Long = 8
Private Const ALG_SID_TEK As Long = 11
Private Const ALG_SID_TLS1_MASTER As Long = 6
Private Const ALG_SID_TLS1PRF As Long = 10
Enum CALG_ID
CALG_3DES = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_3DES)
CALG_3DES_112 = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_3DES_112)
CALG_CYLINK_MEK = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_CYLINK_MEK)
CALG_DES = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_DES)
CALG_DESX = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_DESX)
CALG_RC2 = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC2)
CALG_RC4 = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_RC4)
CALG_RC5 = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC5)
CALG_SEAL = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_SEAL)
CALG_SKIPJACK = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_SKIPJACK)
CALG_TEK = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_TEK)
CALG_AGREEDKEY_ANY = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_DH Or ALG_SID_AGREED_KEY_ANY)
CALG_DH_EPHEM = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_DH Or ALG_SID_DH_EPHEM)
CALG_DH_SF = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_DH Or ALG_SID_DH_SANDF)
CALG_HUGHES_MD5 = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_ANY Or ALG_SID_MD5)
CALG_KEA_KEYX = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_DH Or ALG_SID_KEA)
CALG_RSA_KEYX = (ALG_CLASS_KEY_EXCHANGE Or ALG_TYPE_RSA Or ALG_SID_RSA_ANY)
CALG_DSS_SIGN = (ALG_CLASS_SIGNATURE Or ALG_TYPE_DSS Or ALG_SID_DSS_ANY)
CALG_RSA_SIGN = (ALG_CLASS_SIGNATURE Or ALG_TYPE_RSA Or ALG_SID_RSA_ANY)
CALG_PCT1_MASTER = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_PCT1_MASTER)
CALG_SCHANNEL_ENC_KEY = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_SCHANNEL_ENC_KEY)
CALG_SCHANNEL_MAC_KEY = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_SCHANNEL_MAC_KEY)
CALG_SCHANNEL_MASTER_HASH = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_SCHANNEL_MASTER_HASH)
CALG_SSL2_MASTER = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_SSL2_MASTER)
CALG_SSL3_MASTER = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_SSL3_MASTER)
CALG_TLS1_MASTER = (ALG_CLASS_MSG_ENCRYPT Or ALG_TYPE_SECURECHANNEL Or ALG_SID_TLS1_MASTER)
CALG_HMAC = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_HMAC)
CALG_MAC = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MAC)
CALG_MD2 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
CALG_MD4 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
CALG_MD5 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
CALG_SHA = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
CALG_SHA1 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1)
CALG_SSL3_SHAMD5 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SSL3SHAMD5)
CALG_TLS1PRF = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_TLS1PRF)
End Enum
'Crypt Provider
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (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" (hProv As Long, dwFlags As Long) As Long
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const PROV_RSA_FULL As Long = 1
Private Const NTE_BAD_KEYSET As Long = &H80090016
Private Const CRYPT_NEWKEYSET As Long = &H8
'create hash
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 CryptDestroyHash Lib "advapi32.dll" (hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, pbyte As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Const PP_NAME As Long = 4
Private Const PP_CONTAINER As Long = 6
Private Const HP_HASHSIZE As Long = &H4
Private Const HP_HASHVAL As Long = &H2
'create session key
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 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, pbData As Any, pdwDataLen As Long, ByVal dwFlags 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 CryptGetUserKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwKeySpec As Long, phUserKey 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, pbData As Any, pdwDataLen As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32.dll" (ByVal hProv As Long, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, phKey As Long) As Long
Private Const CRYPT_EXPORTABLE As Long = &H1
Private Const KP_KEYLEN As Long = 9
Private Const AT_KEYEXCHANGE As Long = 1
Private Const NTE_NO_KEY As Long = &H8009000D
Private Const SIMPLEBLOB As Long = &H1
'Encrypt Decrypt
Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, pbData As Any, 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, pbData As Any, pdwDataLen As Long) As Long
'Enum CSP Providers
Private Declare Function CryptEnumProviders Lib "advapi32.dll" Alias "CryptEnumProvidersA" (ByVal dwIndex As Long, ByVal pdwReserved As Any, ByVal dwFlags As Long, pdwProvType As Long, ByVal pszProvName As String, pcbProvName As Long) As Long
Private Declare Function CryptEnumProviderTypes Lib "advapi32.dll" Alias "CryptEnumProviderTypesA" (ByVal dwIndex As Long, ByVal pdwReserved As Any, ByVal dwFlags As Long, pdwProvType As Long, ByVal pszTypeName As String, pcbTypeName As Long) As Long
Private Declare Function CryptGetDefaultProvider Lib "advapi32.dll" Alias "CryptGetDefaultProviderA" (ByVal dwProvType As Long, ByVal pdwReserved As Any, ByVal dwFlags As Long, ByVal pszProvName As String, pcbProvName As Long) As Long
Private Declare Function CryptGetProvParam Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwParam As Long, pbyte As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Const PP_ENUMALGS As Long = 1
Private Const CRYPT_FIRST As Long = 1
Private Const CRYPT_NEXT As Long = 2
'util function
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, source As Any, ByVal length As Long)
Private Declare Function CreateFileA Lib "kernel32.dll" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Any) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const CREATE_ALWAYS As Long = 2
Private Const OPEN_EXISTING As Long = 3
'possible error code
Private Const ERROR_INVALID_HANDLE As Long = 6
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const NTE_BAD_ALGID As Long = &H80090008
Private Const NTE_BAD_FLAGS As Long = &H80090009
Private Const NTE_BAD_HASH As Long = &H80090002
Private Const NTE_BAD_HASH_STATE As Long = &H8009000C
Private Const NTE_BAD_UID As Long = &H80090001
Private Const NTE_FAIL As Long = &H80090020
Private Const NTE_SILENT_CONTEXT As Long = &H80090022
Private Const ERROR_MORE_DATA As Long = &HEA&
'class variable
Private hProv As Long 'handle to Crypt Provider
Private hHash As Long 'handle to hash object
Private hKey As Long 'handle to session key
Const ProvType As Long = PROV_RSA_FULL 'Provider Type to be use
'-----------------------------
'Internal class sub
'-----------------------------
Private Sub Class_Initialize()
' http://msdn.microsoft.com/en-us/library/aa379886%28VS.85%29.aspx
'Get a handle to the default PROV_RSA_FULL provider. If the function succeeds, the function returns nonzero
If CryptAcquireContext(hProv, vbNullString, vbNullString, ProvType, 0&) = 0 Then
If Err.LastDllError = NTE_BAD_KEYSET Then
'No default container was found. Attempt to create it.
If CryptAcquireContext(hProv, vbNullString, vbNullString, ProvType, CRYPT_NEWKEYSET) = 0 Then
ErrRaise "CryptAcquireContext newkeyset"
End If
Else
ErrRaise "CryptAcquireContext default"
End If
End If
End Sub
Private Sub Class_Terminate()
If hKey <> 0 Then CryptDestroyKey hKey
If hHash <> 0 Then CryptDestroyHash hHash
If hProv <> 0 Then CryptReleaseContext hProv, 0&
End Sub
'------------------------
'List supported CALG
'------------------------
Public Function EnumCspProvider()
' http://msdn.microsoft.com/en-us/library/aa382359%28v=VS.85%29.aspx
' List available CSP Provider and Supported algorithm
Dim i As Long: i = 0
Dim ProvType As Long
Dim name As String
Dim n As Long
'Enum Provider Types
Debug.Print "Provider Type" & vbTab & "Provider TypeName" & vbCrLf & String(30, "-")
While CryptEnumProviderTypes(i, vbNullString, 0&, ProvType, vbNullString, n) <> 0
name = Space(n - 1) 'exclude terminating null
If CryptEnumProviderTypes(i, vbNullString, 0&, ProvType, name, n) = 0 Then ErrRaise "CryptEnumProviderTypes"
Debug.Print ProvType & String(4, vbTab) & name
i = i + 1
Wend
'Enum Providers Name
i = 0
Debug.Print "Provider Type" & vbTab & "Provider Name" & vbCrLf & String(30, "-")
While CryptEnumProviders(i, vbNullString, 0&, ProvType, vbNullString, n) <> 0
name = Space(n - 1) 'exclude terminating null
If CryptEnumProviders(i, vbNullString, 0&, ProvType, name, n) = 0 Then ErrRaise "CryptEnumProviders"
Debug.Print ProvType & String(4, vbTab) & name
i = i + 1
Wend
'Get the name of the default CSP specified for the PROV_RSA_FULL type for the computer.
If CryptGetDefaultProvider(ProvType, vbNullString, 0&, vbNullString, n) = 0 Then ErrRaise "CryptGetDefaultProvider"
name = Space(n - 1)
If CryptGetDefaultProvider(ProvType, vbNullString, 0&, name, n) = 0 Then ErrRaise "CryptGetDefaultProvider"
Debug.Print "Default Provider Name : " & name
'Enumerate the supported algorithms.
Dim flag As Long: flag = CRYPT_FIRST
Dim algid As Long
Dim dwBits As Long
Dim nameLen As Long
Dim algType As String
If CryptGetProvParam(hProv, PP_ENUMALGS, ByVal vbNullString, n, flag) = 0 Then ErrRaise "CryptGetProvParam"
Dim b() As Byte: ReDim b(n - 1)
Debug.Print "ALGID" & vbTab & "dwBits" & vbTab & "algType" & String(3, vbTab) & "namelen" & vbTab & "Name" & vbCrLf & String(30, "-")
While CryptGetProvParam(hProv, PP_ENUMALGS, b(0), n, flag) <> 0
flag = CRYPT_NEXT
RtlMoveMemory algid, b(0), LenB(algid)
RtlMoveMemory dwBits, b(4), LenB(dwBits)
RtlMoveMemory nameLen, b(8), LenB(nameLen)
name = Space(nameLen \ 2)
RtlMoveMemory ByVal StrPtr(name), b(12), nameLen - 1
Select Case (algid And &HF000)
Case ALG_CLASS_ANY: algType = "Any "
Case ALG_CLASS_SIGNATURE: algType = "Signature "
Case ALG_CLASS_MSG_ENCRYPT: algType = "Msg_Encrypt "
Case ALG_CLASS_DATA_ENCRYPT: algType = "Data_Encrypt"
Case ALG_CLASS_HASH: algType = "Hash "
Case ALG_CLASS_KEY_EXCHANGE: algType = "Exchange "
Case Else: algType = "Unknwon "
End Select
Debug.Print algid & vbTab & Right(" " & dwBits, 6) & vbTab & algType & vbTab & nameLen & vbTab & vbTab & StrConv(name, vbUnicode)
Wend
End Function
'------------------------------
'HASH
'------------------------------
Private Function CreateHash(CALG As CALG_ID)
' CreateHash Handle first before calling CryptHashData
If (CALG And ALG_CLASS_HASH) <> ALG_CLASS_HASH Then ErrRaise "Invalid CALG, not a ALG_CLASS_HASH type"
If CryptCreateHash(hProv, CALG, 0&, 0&, hHash) = 0 Then ErrRaise "CryptCreateHash"
End Function
Private Function GetHash() As Byte()
' Get hash value after CryptHashData
Dim n As Long
If CryptGetHashParam(hHash, HP_HASHSIZE, n, LenB(n), 0&) = 0 Then ErrRaise "CryptGetHashParam"
Dim b() As Byte: ReDim b(n - 1)
If CryptGetHashParam(hHash, HP_HASHVAL, b(0), n, 0&) = 0 Then ErrRaise "CryptGetHashParam"
GetHash = b
End Function
Public Function HashData(data As Variant, Optional CALG As CALG_ID = CALG_MD5) As String
' create hash from variant datatype by converting it to bytearray
Dim b() As Byte: b = VariantToBytes(data, False, True)
CreateHash CALG
If CryptHashData(hHash, b(0), UBound(b) + 1, 0&) = 0 Then ErrRaise "CryptHashData"
HashData = CHex(GetHash())
End Function
Public Function HashFile(filename As String, Optional CALG As CALG_ID = CALG_MD5) As String
' http://msdn.microsoft.com/en-us/library/aa382380%28VS.85%29.aspx
' create hash from file contents
On Error GoTo ErrHandler
Const BUFSIZE As Long = 1074
Dim b() As Byte: ReDim b(BUFSIZE - 1)
Dim n As Long
Dim hFile As Long
CreateHash CALG
hFile = CreateFileA(filename, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
If hFile = -1 Then ErrRaise "Unable to open file " & filename
Do
If ReadFile(hFile, b(0), BUFSIZE, n, 0&) = 0 Then ErrRaise "ReadFile"
If CryptHashData(hHash, b(0), n, 0&) = 0 Then ErrRaise "CryptHashData"
Loop Until n < BUFSIZE
HashFile = CHex(GetHash())
ExitHere:
If hFile <> -1 Then CloseHandle hFile
Exit Function
ErrHandler:
HandleError "HashFile()"
Resume ExitHere
End Function
'-------------------------------------
'EncryptDecrypt File/String/Byte
'-------------------------------------
Public Function EncryptFile(CALG As CALG_ID, src As String, dest As String, Optional pwd As String)
EncryptDecryptFile "Encrypt", CALG, src, dest, pwd
End Function
Public Function DecryptFile(CALG As CALG_ID, src As String, dest As String, Optional pwd As String)
EncryptDecryptFile "Decrypt", CALG, src, dest, pwd
End Function
Private Function EncryptDecryptFile(op As String, CALG As CALG_ID, src As String, dest As String, Optional pwd As String)
' http://msdn.microsoft.com/en-us/library/aa382358%28v=VS.85%29.aspx
' http://msdn.microsoft.com/en-us/library/aa382044(v=VS.85).aspx
On Error GoTo ErrHandler
If (CALG And ALG_CLASS_DATA_ENCRYPT) <> ALG_CLASS_DATA_ENCRYPT Then ErrRaise "Invalid CALG, not a DATA_ENCRYPT type"
'block Length must be a multiple of ENCRYPT_BLOCK_SIZE
Const ENCRYPT_BLOCK_SIZE As Long = 8
Dim blockLen As Long: blockLen = 1000 - 1000 Mod ENCRYPT_BLOCK_SIZE
Dim BUFSIZE As Long: BUFSIZE = blockLen + ENCRYPT_BLOCK_SIZE
Dim b() As Byte: ReDim b(BUFSIZE - 1)
Dim n As Long
Dim hSrcFile As Long
Dim hDestFile As Long
'open src file for read, dest file for write
hSrcFile = CreateFileA(src, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
If hSrcFile = -1 Then ErrRaise "Unable to open file " & src
hDestFile = CreateFileA(dest, GENERIC_WRITE, FILE_SHARE_READ, 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
If hDestFile = -1 Then ErrRaise "Unable to open file " & dest
'create session key
If pwd <> "" Then
CreateSessionKey CALG, pwd
Else
Dim key() As Byte
If op = "Encrypt" Then
key = CreateRandomSessionKey(CALG)
'write key length & key blob
If WriteFile(hDestFile, CByte(UBound(key) + 1), 1, n, 0&) = 0 Then ErrRaise "WriteFile"
If WriteFile(hDestFile, key(0), UBound(key) + 1, n, 0&) = 0 Then ErrRaise "WriteFile"
Else
Dim keyLength As Byte
'read key length and assign buffer
If ReadFile(hSrcFile, keyLength, LenB(keyLength), n, 0&) = 0 Then ErrRaise "ReadFile"
ReDim key(keyLength - 1)
'get key blob
If ReadFile(hSrcFile, key(0), keyLength, n, 0&) = 0 Then ErrRaise "ReadFile"
If CryptImportKey(hProv, key(0), keyLength, 0&, 0&, hKey) = 0 Then ErrRaise "CryptImportKey"
End If
End If
'Encrypt/Decrypt and write to dest file
Dim eof As Long: eof = 0
Do
If ReadFile(hSrcFile, b(0), BUFSIZE, n, vbNullString) = 0 Then ErrRaise "ReadFile"
If n < BUFSIZE Then eof = 1
If op = "Encrypt" Then
If CryptEncrypt(hKey, 0&, eof, 0&, b(0), n, UBound(b) + 1) = 0 Then ErrRaise "CryptEncrypt"
Else
If CryptDecrypt(hKey, 0&, eof, 0&, b(0), n) = 0 Then ErrRaise "CryptDecrypt"
End If
If WriteFile(hDestFile, b(0), n, n, 0&) = 0 Then ErrRaise "WriteFile"
Loop Until eof = 1
ExitHere:
If hSrcFile <> -1 Then CloseHandle hSrcFile
If hDestFile <> -1 Then CloseHandle hDestFile
Exit Function
ErrHandler:
HandleError "EncryptDecryptFile()"
Resume ExitHere
End Function
Public Function EncryptData(CALG As CALG_ID, data As Variant, Optional pwd As String) As Byte()
' Encrypt any data passed in, numeric will be converted to byte array
Dim b() As Byte: b = VariantToBytes(data, False)
'append vartype to buffer
ReDim Preserve b(UBound(b) + 2)
RtlMoveMemory b(UBound(b) - 1), CInt(VarType(data)), 2
'encrypt the bytes
EncryptData = EncryptDecryptBytes("Encrypt", CALG, b, pwd)
End Function
Public Function DecryptData(CALG As CALG_ID, data() As Byte, Optional pwd As String) As Variant
Dim b() As Byte
Dim VarType As Integer
'decrypt the bytes
b = EncryptDecryptBytes("Decrypt", CALG, data, pwd)
'get vartype from end of buffer (2 bytes)
RtlMoveMemory VarType, b(UBound(b) - 1), LenB(VarType)
ReDim Preserve b(UBound(b) - 2)
'convert to variant according to vartype
DecryptData = BytesToVariant(VarType, b, False)
End Function
Private Function EncryptDecryptBytes(op As String, CALG As CALG_ID, b() As Byte, Optional pwd As String) As Byte()
' http://msdn.microsoft.com/en-us/library/aa382358%28v=VS.85%29.aspx
' http://msdn.microsoft.com/en-us/library/aa382044(v=VS.85).aspx
On Error GoTo ErrHandler
If UBound(b) = -1 Then Exit Function
If (CALG And ALG_CLASS_DATA_ENCRYPT) <> ALG_CLASS_DATA_ENCRYPT Then ErrRaise "Invalid CALG, not a DATA_ENCRYPT type"
'block Length must be a multiple of ENCRYPT_BLOCK_SIZE
Const ENCRYPT_BLOCK_SIZE As Long = 8
Dim blockLen As Long: blockLen = 1000 - 1000 Mod ENCRYPT_BLOCK_SIZE
Dim BUFSIZE As Long: BUFSIZE = blockLen + ENCRYPT_BLOCK_SIZE
Dim buf() As Byte: ReDim buf(BUFSIZE - 1)
Dim n As Long
'create session key
Dim key() As Byte
If pwd <> "" Then
key = CreateSessionKey(CALG, pwd)
Else
If op = "Encrypt" Then
key = CreateRandomSessionKey(CALG)
Else
Dim keyLength As Byte
'read key length and assign buffer
RtlMoveMemory keyLength, b(UBound(b)), 1
ReDim key(keyLength - 1)
'get key blob
RtlMoveMemory key(0), b(UBound(b) - keyLength), keyLength
If CryptImportKey(hProv, key(0), keyLength, 0&, 0&, hKey) = 0 Then ErrRaise "CryptImportKey"
'remove key from byte array
ReDim Preserve b(UBound(b) - keyLength - 1)
End If
End If
'Encrypt/Decrypt and return result
'TODO: buf size is 1008, solve case when input byte array is larger than 1008
n = UBound(b) + 1
RtlMoveMemory buf(0), b(0), n
If op = "Encrypt" Then
If CryptEncrypt(hKey, 0&, 1&, 0&, buf(0), n, UBound(buf) + 1) = 0 Then ErrRaise "CryptEncrypt"
Else
If CryptDecrypt(hKey, 0&, 1&, 0&, buf(0), n) = 0 Then ErrRaise "CryptDecrypt"
End If
ReDim Preserve buf(n - 1)
'write random sessionkey to the end of buffer
If op = "Encrypt" And pwd = "" Then
ReDim Preserve buf(UBound(buf) + UBound(key) + 2)
'write key length & key blob
RtlMoveMemory buf(UBound(buf)), CByte(UBound(key) + 1), 1
RtlMoveMemory buf(UBound(buf) - UBound(key) - 1), key(0), UBound(key) + 1
End If
EncryptDecryptBytes = buf
ExitHere:
Exit Function
ErrHandler:
HandleError "EncryptDecryptBytes()"
Resume ExitHere
End Function
'---------------------------
'Session Key
'---------------------------
Private Function CreateSessionKey(CALG As CALG_ID, pwd As String) As Byte()
' create session key base on pwd string
If pwd = "" Then ErrRaise "pwd cannot be empty string"
HashData pwd, CALG_MD5
If CryptDeriveKey(hProv, CALG, hHash, CRYPT_EXPORTABLE, hKey) = 0 Then ErrRaise "CryptDeriveKey"
' CreateSessionKey = GetKeyBlob()
End Function
Private Function CreateRandomSessionKey(CALG As CALG_ID) As Byte()
' create random session key and return the encrypted session key in simple BLOB
If CryptGenKey(hProv, CALG, CRYPT_EXPORTABLE, hKey) = 0 Then ErrRaise "CryptGenKey"
CreateRandomSessionKey = GetKeyBlob()
End Function
Private Function GetKeyBlob() As Byte()
' Get the SessionKey in byte array (140 bytes)
On Error GoTo ErrHandler
'Get the handle to the exchange public key
Dim hExchange As Long
If CryptGetUserKey(hProv, AT_KEYEXCHANGE, hExchange) = 0 Then
If Err.LastDllError = NTE_NO_KEY Then
'No exchange key exists. Try to create one.
If CryptGenKey(hProv, AT_KEYEXCHANGE, CRYPT_EXPORTABLE, hKey) = 0 Then ErrRaise "CryptGenKey fail newkey"
Else
ErrRaise "CryptGetUserKey"
End If
End If
'Encrypt and export the session key into a simple key BLOB
Dim n As Long
If CryptExportKey(hKey, hExchange, SIMPLEBLOB, 0&, ByVal vbNullString, n) = 0 Then ErrRaise "CryptExportKey fail GetBlobSize"
Dim b() As Byte: ReDim b(n - 1)
If CryptExportKey(hKey, hExchange, SIMPLEBLOB, 0&, b(0), UBound(b) + 1) = 0 Then ErrRaise "CryptExportKey fail export key"
GetKeyBlob = b
ExitHere:
If hExchange <> 0 Then CryptDestroyKey hExchange
Exit Function
ErrHandler:
HandleError "GetKeyBlob()"
Resume ExitHere
End Function
'------------------------------
'Helper Function
'------------------------------
Private Function CHex(var As Variant, Optional separator As String = "") As String
' Convert variant into Hex$ string. Built-in function VBA.Hex$ only take numeric input up to 4bytes
' vbObject return Hex$ of object address
' vbString return ANSI Hex$
' numeric numbers return Hex$ of data representation on memory (Big Endian Order)
On Error GoTo ErrHandler
Dim b() As Byte: b = VariantToBytes(var, True, False)
'convert the buffer into hex string
Dim i: For i = 0 To UBound(b)
CHex = CHex & Right("0" & VBA.hex$(b(i)), 2) & separator
Next
ExitHere:
Exit Function
ErrHandler:
HandleError "CHex()"
Resume ExitHere
End Function
Private Function VariantToBytes(var As Variant, Optional ConvertStringToAnsi As Boolean = True, Optional LittleEndian As Boolean = True) As Byte()
' ConvertStringToAnsi : If var is a string type, whether or not to convert it into ANSI
' LittleEndian : Computer store numeric value in little endian order, whether return the bytes in LittleEndian or BigEndian Order
' vbObject return object address
' numeric numbers return data representation on memory
Dim b() As Byte
Dim n As Long
Dim i As Integer
'determine vartype and allocate the buffer needed
Select Case VarType(var)
Case vbString: b = IIf(ConvertStringToAnsi, StrConv(var, vbFromUnicode), var)
Case vbArray + vbByte: b = var
Case vbByte: ReDim b(0)
Case vbInteger, vbBoolean: ReDim b(1)
Case vbLong, vbSingle, vbObject: ReDim b(3)
Case vbDouble, vbCurrency, vbDate: ReDim b(7)
Case vbDecimal: ReDim b(11)
Case vbEmpty, vbNull: ErrRaise "Empty or Null Data"
Case Else: ErrRaise "Unknown VarType : " & VarType(var)
End Select
If VarType(var) <> vbString And VarType(var) <> vbArray + vbByte Then
'move the variant value into buffer
RtlMoveMemory n, ByVal VarPtr(var) + 1, 1
If n = &H40 Then
'offset 8 store the pointer to data
RtlMoveMemory n, ByVal VarPtr(var) + 8, LenB(n)
Else
'offset 8 store the data
n = VarPtr(var) + 8
End If
'return as LittleEndian or BigEndian
If LittleEndian Then
RtlMoveMemory b(0), ByVal n, UBound(b) + 1
Else ' mirrow the bytes
For i = 0 To UBound(b)
RtlMoveMemory b(i), ByVal n + (UBound(b) - i), 1
Next
End If
End If
VariantToBytes = b
End Function
Private Function BytesToVariant(VarType As Integer, b() As Byte, Optional StringIsAnsi As Boolean = True) As Variant
' The reverse process of VariantToBytes() function, VarType must be known beforehand
' b() array must be in LittleEndian byte order for numeric value
Dim var As Variant
If VarType = vbInteger Or VarType = vbLong Or VarType = vbCurrency Then
Dim i: For i = 0 To UBound(b)
var = var + (b(i) * 256 ^ i)
Next
End If
Select Case VarType
Case vbString: BytesToVariant = IIf(StringIsAnsi, StrConv(CStr(b), vbUnicode), CStr(b))
Case vbArray + vbByte: BytesToVariant = b
Case vbByte: BytesToVariant = b(0)
Case vbBoolean: BytesToVariant = (b(0) <> 0) 'boolean store false as &H0000
Case vbInteger: BytesToVariant = CInt(var)
Case vbLong: BytesToVariant = CLng(var)
Case vbCurrency: BytesToVariant = CCur(var / 10000)
Case vbSingle:
Dim s As Single
RtlMoveMemory s, b(0), LenB(s)
BytesToVariant = s
Case vbDouble:
Dim d As Double
RtlMoveMemory d, b(0), LenB(d)
BytesToVariant = d
Case vbDate:
Dim dt As Date
RtlMoveMemory dt, b(0), LenB(dt)
BytesToVariant = dt
Case vbDecimal: 'Error Automation not supported in visual basic
RtlMoveMemory var, b(0), 12
BytesToVariant = CDec(var)
Case vbObject: ErrRaise "vbObject not supported"
Case vbEmpty, vbNull: ErrRaise "Empty or Null Data"
Case Else: ErrRaise "Unknown VarType : " & VarType
End Select
End Function
