Wednesday, November 24, 2010

Crypto API

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 Sub

Sample 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

Download here: CCrypt.cls
Require basErrHandler: basErrHandler.bas

Tuesday, November 23, 2010

Log Update Delete

Track record changes, when users delete or update a record, the following code will show how to do it. This will also log any record(s) effected by cascade delete relation recursively.
 

Require to setup two tables, LogUpdateDelete and LogUpdateDeleteTmp, if you split your database into backend, put LogUpdateDelete on backend and LogUpdateDeleteTmp on frontend.
Table Structure:
DateTime (Date/Time)
User (Text)
LocalIP (Text)
SystemInfo (Text)
Op (Text)
Table (Text)
OldData (Memo) Property AppendOnly=No
NewData (Memo) Property AppendOnly=No



This will also need basSystemInfo.bas which i posted earlier on GetIpAddress Topic.
Known Issue: when the form RecordSource is base on query, the primary key must be on the first field on the query design, otherwise it won't log the CascadeDelete.

'14:57 04/11/2010 Update: Add check for Relationship on linked backend db
'09:48 12/10/2010 trying to access form Recordset property during BeforeDelete Event,
'                 sometimes will cause form to lose its recordsource when delete is canceled
'                 eg. Msgbox frm.Recordset.AbsolutePosition on OnDelete() function
'15:55 04/10/2010 Purpose: Log record update and delete into a table, including cascade delete
'
'Copyright © 2010 RENO

Option Compare Text
'Option Explicit
#Const OPTION_EXPLICIT = False


Private Const logTable As String = "LogUpdateDelete"
Private Const tmpTable As String = "LogUpdateDeleteTmp"
Private sBookmark      As String   'var to check if record(s) is deleted on ConfirmDelete

'---------------------------------------------------------------------------------
'insert this 4 functions into each form that need logging
'EVENT                      MACRO
'On Delete                  =OnDelete([Form])
'After Del Confirm          =ConfirmDelete([Form])
'Before Update              =BeforeUpdate([Form])
'After Update               =ConfirmUpdate([Form])
'
'Alternative: use InsertIntoForms() to quickly add the code into All Forms
'---------------------------------------------------------------------------------
Public Function OnDelete(frm As Form)
'   save current record before the record is actually deleted
'   if more than one records is deleted, this event will be trigger for each of the record
On Error GoTo ErrHandler
    'save the current bookmark to check record status on ConfirmDelete function
    sBookmark = frm.Bookmark
    LogTempTable frm, "Delete"
ExitHere:
    Exit Function
ErrHandler:
    HandleError "OnDelete()"
    DoCmd.CancelEvent
    Resume ExitHere
End Function

Public Function ConfirmDelete(frm As Form) As Boolean
'   Check if the record has been deleted, and update Log Table
'   Triggered only once even more than one records is deleted
'   return true if user press 'Yes' on the confirm msgbox
On Error Resume Next
    'if the record is deleted, this line of code will raise an error
    frm.Bookmark = sBookmark
    ConfirmDelete = (Err.Number = 3167) 'Or Err.Number = 3021 'record deleted
    
On Error GoTo ErrHandler
    If ConfirmDelete = True Then
        CurrentDb.Execute "INSERT INTO " & logTable & " SELECT * FROM " & tmpTable
    End If
    'clear temp table
    CurrentDb.Execute "DELETE FROM " & tmpTable
ExitHere:
    Exit Function
ErrHandler:
    HandleError "ConfirmDelete()"
    Resume ExitHere
End Function

Public Function BeforeUpdate(frm As Form)
    #If OPTION_EXPLICIT = False Then
        'set UpdatedOn and UpdatedBy Field, use ajbFieldLevel module if exist
        'http://allenbrowne.com/ser-55.html
        On Error Resume Next
        ajbFieldLevel.StampRecord frm
    #End If
On Error GoTo ErrHandler
    If frm.NewRecord = False Then LogTempTable frm, "Update"
ExitHere:
    Exit Function
ErrHandler:
    HandleError "BeforeUpdate()"
    DoCmd.CancelEvent
    Resume ExitHere
End Function

Public Function ConfirmUpdate(frm As Form)
On Error GoTo ErrHandler
    If frm.NewRecord Then Exit Function
    
    'update tmp table with new values after update
    frm.Recordset.Bookmark = frm.Bookmark
    Dim f As DAO.Field: For Each f In frm.Recordset.Fields
        ConfirmUpdate = ConfirmUpdate & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
    Next
    
    'insert BeforeUpdate and AfterUpdate data into logTable
    CurrentDb.Execute "UPDATE " & tmpTable & " SET NewData=""" & Replace(ConfirmUpdate, """", "'") & """"
    CurrentDb.Execute "INSERT INTO " & logTable & " SELECT * FROM " & tmpTable
    'clear temp table
    CurrentDb.Execute "DELETE FROM " & tmpTable
ExitHere:
    Exit Function
ErrHandler:
    HandleError "ConfirmUpdate()"
    Resume ExitHere
End Function

Public Function CloseRecordset(ByRef rs As DAO.Recordset)
'   helper function to close Recordset
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
End Function

'-------------------------------------------------------------------------------
'internal method
'LogTempTable -> LogCascade -> GetCascadeRelation -> GetCascadeRelationInDB
'-------------------------------------------------------------------------------
Private Function LogTempTable(frm As Form, op As String)
'   Save current record to temp table
'   op - operation "Update" or "Delete"
On Error GoTo ErrHandler
    Dim rsCurrent   As DAO.Recordset
    Dim rsTemp      As DAO.Recordset
    
    DoCmd.Hourglass True
    'need this to avoid form losing recordsource
    Set rsCurrent = frm.RecordsetClone
    rsCurrent.Bookmark = frm.Bookmark
        
    'save the current record to temp table
    Dim f As DAO.Field:  For Each f In rsCurrent.Fields
        LogTempTable = LogTempTable & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
    Next
    
    'log update/delete attempt to tmptable
    Set rsTemp = CurrentDb.OpenRecordset(tmpTable, , dbAppendOnly)
    rsTemp.AddNew
    rsTemp!DateTime = Now()
    rsTemp!op = op
    rsTemp!user = UserName()
    rsTemp!LocalIP = Left$(LocalIP(), 255)
    rsTemp!SystemInfo = Left$(SystemInfo(), 255)
    rsTemp!table = frm.RecordSource
    rsTemp!OldData = Replace(LogTempTable, """", "'")
    rsTemp.Update
    
    LogCascade op, rsCurrent, rsTemp
ExitHere:
    CloseRecordset rsTemp
    CloseRecordset rsCurrent
    DoCmd.Hourglass False
    Exit Function
ErrHandler:
    HandleError "LogTempTable()"
    Resume ExitHere
End Function

Private Function LogCascade(op As String, rsCurrent As DAO.Recordset, rsTemp As DAO.Recordset)
'   Recursively Log DeleteCascade for the Recordset specified in rsCurrent
'   rsCurrent - current recordset position in which to search for cascade relation
'   rsTemp - input recordset pointed to tmpTable
On Error GoTo ErrHandler
    Dim rel         As DAO.Relation
    Dim rsCascade   As DAO.Recordset
    
    'check for cascade delete
    If op = "Delete" Then Set rel = GetCascadeRelation(rsCurrent.Fields(0), dbRelationDeleteCascade)
    If Not rel Is Nothing Then
        'build sql string to retrieve effected records by cascade delete
        Dim str: str = "SELECT * FROM [" & rel.ForeignTable & "] WHERE [" & rel.Fields(0).ForeignName & "]="
        Select Case rsCurrent.Fields(0).Type
            Case dbText: str = str & """" & rsCurrent.Fields(0).value & """"
            Case dbDate: str = str & Format(rsCurrent.Fields(0).value, "\#mm\/dd\/yyyy\#")
            Case Else:   str = str & rsCurrent.Fields(0).value
        End Select
        
        'log the effected records to tmp table
        Set rsCascade = CurrentDb.OpenRecordset(str)
        While Not rsCascade.EOF
            LogCascade = ""
            Dim f As DAO.Field: For Each f In rsCascade.Fields
                LogCascade = LogCascade & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
            Next
            rsTemp.AddNew
            rsTemp!DateTime = Now()
            rsTemp!op = "Cascade" & op
            rsTemp!user = UserName()
            rsTemp!LocalIP = Left$(LocalIP(), 255)
            rsTemp!SystemInfo = Left$(SystemInfo(), 255)
            rsTemp!table = rsCascade.Fields(0).SourceTable
            rsTemp!OldData = Replace(LogCascade, """", "'")
            rsTemp.Update
            
            'recursive call to log futher cascade
            LogCascade op, rsCascade, rsTemp
            rsCascade.MoveNext
        Wend
    End If
ExitHere:
    CloseRecordset rsCascade
    Exit Function
ErrHandler:
    HandleError "LogCascade()"
    Resume ExitHere
End Function

Private Function GetCascadeRelation(fld As DAO.Field, CascadeType As RelationAttributeEnum) As DAO.Relation
'   check if a Field is in relation to another table by CascadeType
'   return relation
On Error GoTo ErrHandler
    Dim rs As DAO.Recordset
    Dim db As DAO.Database
    
    'check relation in current db
    Set GetCascadeRelation = GetCascadeRelationInDB(CurrentDb, fld, CascadeType)
    If Not GetCascadeRelation Is Nothing Then GoTo ExitHere
        
    '14:57 04/11/2010 check relation in linked tables
    Set rs = CurrentDb.OpenRecordset("SELECT Database, Connect From MSysObjects Where Flags=2097152 Group By Database, Connect")
    While Not rs.EOF
        Set db = OpenDatabase(rs.Fields(0), False, True, rs.Fields(1))
        Set GetCascadeRelation = GetCascadeRelationInDB(db, fld, CascadeType)
        db.Close
        Set db = Nothing
        rs.MoveNext
        If Not GetCascadeRelation Is Nothing Then GoTo ExitHere
    Wend
ExitHere:
    CloseRecordset rs
    Exit Function
ErrHandler:
    HandleError "GetCascadeRelation()"
    Resume ExitHere
End Function

Private Function GetCascadeRelationInDB(db As DAO.Database, fld As DAO.Field, CascadeType As RelationAttributeEnum) As DAO.Relation
'   14:57 04/11/2010 call by GetCascadeRelation to check if a Field is in relation to another table
    Dim rel As DAO.Relation
    For Each rel In db.Relations
        If (rel.Attributes And CascadeType) = CascadeType Then
            If rel.table = fld.SourceTable And rel.Fields(0).name = fld.SourceField Then
                'found matching relation, clone it
                Set GetCascadeRelationInDB = CurrentDb.CreateRelation(rel.name, rel.table, rel.ForeignTable, rel.Attributes)
                Dim i: For i = 0 To rel.Fields.count - 1
                    GetCascadeRelationInDB.Fields.Append GetCascadeRelationInDB.CreateField(rel.Fields(i).name)
                    GetCascadeRelationInDB.Fields(i).ForeignName = rel.Fields(i).ForeignName
                Next
                Exit Function
            End If
        End If
    Next
End Function

'----------------------------------
'function for debugging
'----------------------------------
Private Sub InsertIntoForms()
'   script to insert above four functions into all the forms Event handler
    Dim f       As AccessObject
    Dim frm     As Form
    Dim s       As String
    For Each f In CurrentProject.AllForms
    If Not f.name Like "frm*" And Not f.name Like "view*" And f.name <> "_MAIN MENU" And Not f.name Like "*Lookup" Then
        If f.IsLoaded Then DoCmd.Close acForm, f.name
        DoCmd.OpenForm f.name, acDesign
        
        Set frm = Forms(f.name)
        Debug.Print f.name
'        Debug.Print vbTab & "RecordSource=""" & frm.RecordSource & """"
        s = vbTab & "OnDelete" & vbTab & vbTab & frm.OnDelete
        frm.OnDelete = "=OnDelete([Form])"
        Debug.Print s & " ---> " & frm.OnDelete & """ "
        
        s = vbTab & "AfterDelConfirm" & vbTab & frm.AfterDelConfirm
        frm.AfterDelConfirm = "=ConfirmDelete([Form])"
        Debug.Print s & " ---> " & frm.AfterDelConfirm; ""
        
        s = vbTab & "BeforeUpdate" & vbTab & frm.BeforeUpdate
        frm.BeforeUpdate = "=BeforeUpdate([Form])"
        Debug.Print s & " ---> " & frm.BeforeUpdate; ""
        
        s = vbTab & "AfterUpdate" & vbTab & vbTab & frm.AfterUpdate
        frm.AfterUpdate = "=ConfirmUpdate([Form])"
        Debug.Print s & " ---> " & frm.AfterUpdate
        
        DoCmd.Close acForm, f.name, acSaveYes
    End If
    Next
End Sub

Private Sub ShowCurrentDbRelations()
    ShowRelations
End Sub

Private Sub ShowRelations(Optional db As Database)
    Dim rel As Relation
    If db Is Nothing Then Set db = CurrentDb
    For Each rel In db.Relations
        Debug.Print "Relation " & rel.name
        Debug.Print vbTab & "Table = " & rel.table & vbTab & "ForeignTable = " & rel.ForeignTable
        Debug.Print vbTab & "PK=" & rel.table & "." & rel.Fields(0).name & vbTab & "FK=" & rel.ForeignTable & "." & rel.Fields(0).ForeignName
        Debug.Print vbTab & "Attributes=" & rel.Attributes
        Debug.Print vbTab & "DeleteCascade=" & ((rel.Attributes And dbRelationDeleteCascade) = dbRelationDeleteCascade)
        Debug.Print vbTab & "UpdateCascade=" & ((rel.Attributes And dbRelationUpdateCascade) = dbRelationUpdateCascade)
    Next
End Sub
Download Here: basLogUpdateDelete.bas
Download Sample Database (Access 2007): LogUpdateDelete.rar