Solved

Store data to a record encrypted?

Posted on 2009-07-15
2
705 Views
Last Modified: 2012-05-07
Hi:
I need to encrypt the data before adding or updating it to the fields in a record
And decrypt it when brows it on forms, reports or queries.
How come please?
0
Comment
Question by:Mohammad Alsolaiman
2 Comments
 
LVL 84

Accepted Solution

by:
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 500 total points
ID: 24857827
This is a massive subject. Access provides "encryption", but it only insures that users external to your database cannot see this data. Once the database is open in Access, the data is decrypted on the fly, and users can view the tables just as easily as viewing this webpage.

How do you want to encrypt? Will your user provide a hash for the encryption, or will you?

What "level" of encryption? How secure does this need to be?

IMO, in order to do this, you'll need to move to unbound forms. Using this method, you could then (a) capture the data the user enters in the form and then (b) encrypt it before your code writes to the table.

The class module attached uses the Crypto API to do this ... it's not the most secure in the world, but may work for your needs. To use it:

1) From the VBA editor, click Insert - Class Modoule
2) Copy/Paste the code below into that.
3) Save it as "clsEncrypt"

To use it:

Dim clsEncrypt As clsEncrpty
Dim sValue As STring

Set clsEncrypt = New clsEncrypt

With clsEncrypt
  sValue = .DoCryptoEncrypt "yourpassword", "data to be encrypted"
End With

sValue now contains an encrypted version of "data to be encrypted". You'd have to do this to every field as it moves into the database, then use DoCryptoDecrypt when the data comes out of the database. The use of class modules for data manipulation would be in order, IMO. If you're not familiar with class modules, then you're in for a loooooong learning curve.
Option Explicit
 

Private Const CRYPT_NEWKEYSET = &H8
 

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" ( _

    phProv As Long, pszContainer As String, pszProvider As String, _

    ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
 

Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, _

    ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
 

Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, _

    ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
 

Private Declare Function CryptDeriveKey Lib "advapi32.dll" ( _

    ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, _

    phKey As Long) As Long
 

Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
 

Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
 

Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hKey As Long, _

    ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, _

    pdwDataLen As Long, ByVal dwBufLen As Long) As Long
 

Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hKey As Long, _

    ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, _

    pdwDataLen As Long) As Long
 

Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, _

    ByVal dwFlags As Long) As Long
 

Private Declare Function GetLastError Lib "kernel32" () As Long
 

'constants for Cryptography API functions

Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"

Private Const PROV_RSA_FULL = 1

Private Const ALG_CLASS_DATA_ENCRYPT = 24576

Private Const ALG_CLASS_HASH = 32768
 

Private Const ALG_TYPE_ANY = 0

Private Const ALG_TYPE_BLOCK = 1536

Private Const ALG_TYPE_STREAM = 2048
 

Private Const ALG_SID_RC2 = 2
 

Private Const ALG_SID_RC4 = 1

Private Const ALG_SID_MD5 = 3

Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)

Private Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or ALG_SID_RC2)

Private Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
 

Private Const ENCRYPT_ALGORITHM = CALG_RC4

Private Const ENCRYPT_BLOCK_SIZE = 1
 

Private Const CRYPT_EXPORTABLE = 1
 

Public Function DoCryptoEncrypt(sPassword As String, PlainText As String) As String
 

  Dim lHHash As Long

  Dim lHkey As Long

  Dim lResult As Long

  Dim lHExchgKey As Long

  Dim lHCryptprov As Long
 

  Dim sContainer As String

  Dim lCryptLength As Long

  Dim lCryptBufLen As Long

  Dim sCryptBuffer As String
 

  On Error GoTo EncryptError
 

  Dim sOutputBuffer As String
 

  Dim sProvider
 

  'Get handle to the default CSP

  sProvider = MS_DEF_PROV & vbNullChar

  

  If Len(PlainText) = 0 Then

    DoCryptoEncrypt = ""

    Exit Function

  End If
 

  sOutputBuffer = ""
 

  If Not CBool(CryptAcquireContext(lHCryptprov, ByVal _

      sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then

    ' If there is no default key container then create one

    ' using Flags field

    If GetLastError = 0 Then

      If Not CBool(CryptAcquireContext(lHCryptprov, 0&, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then

        sOutputBuffer = PlainText

        GoTo Finished

      End If

    End If

  End If
 

  'Create a hash object

  If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, _

      0, lHHash)) Then

    MsgBox ("Error " & CStr(GetLastError) & _

        " during CryptCreateHash!")

    GoTo Finished

  End If
 

  'Hash in the password text

  If Not CBool(CryptHashData(lHHash, sPassword, _

      Len(sPassword), 0)) Then

    MsgBox ("Error " & CStr(GetLastError) & _

        " during CryptHashData!")

    GoTo Finished

  End If
 

  'Create a session key from the hash object.

  If Not CBool(CryptDeriveKey(lHCryptprov, _

      ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then

    MsgBox ("Error " & CStr(GetLastError) & _

        " during CryptDeriveKey!")

    GoTo Finished

  End If
 

  'Destroy the hash object.

  CryptDestroyHash (lHHash)

  lHHash = 0
 

  'Create a buffer for the CryptEncrypt function

  lCryptLength = Len(PlainText)

  lCryptBufLen = lCryptLength * 2

  sCryptBuffer = String(lCryptBufLen, vbNullChar)

  LSet sCryptBuffer = PlainText
 

  'Encrypt the text data

  If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer, _

      lCryptLength, lCryptBufLen)) Then

    MsgBox ("bytes required:" & CStr(lCryptLength))

    MsgBox ("Error " & CStr(GetLastError) & _

        " during CryptEncrypt!")

  End If
 

  sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
 

Finished:

  'Outa here

  DoCryptoEncrypt = sOutputBuffer
 

  'Destroy session key.

  If (lHkey) Then lResult = CryptDestroyKey(lHkey)
 

  'Destroy key exchange key handle

  If lHExchgKey Then CryptDestroyKey (lHExchgKey)
 

  'Destroy hash object

  If lHHash Then CryptDestroyHash (lHHash)
 

  'Release Context provider handle

  If lHCryptprov Then lResult = _

      CryptReleaseContext(lHCryptprov, 0)
 

  Exit Function
 

EncryptError:
 

  MsgBox ("Encrypt Error: " & Error$)
 

  GoTo Finished
 

End Function
 
 

Public Function DoCryptoDecrypt(sPassword As String, CryptText As String) As String
 

  Dim lHExchgKey As Long

  Dim lHCryptprov As Long

  Dim lHHash As Long

  Dim lHkey As Long

  Dim lResult As Long
 

  Dim sContainer As String

  Dim sProvider As String
 

  Dim sCryptBuffer As String

  Dim lCryptBufLen As Long

  Dim lCryptPoint As Long
 

  Dim lPasswordPoint As Long

  Dim lPasswordCount As Long
 

  Dim sOutputBuffer As String
 

  On Error GoTo DecryptError
 
 

  If Len(CryptText) = 0 Then

    DoCryptoDecrypt = ""

    Exit Function

  End If

  'Clear the Output buffer

  sOutputBuffer = ""
 

  'Get handle to the default CSP.

  sContainer = vbNullChar

  sProvider = vbNullChar

  sProvider = MS_DEF_PROV & vbNullChar

  If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then

    If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then

      'MsgBox ("Error " & CStr(GetLastError) & " during CryptAcquireContext! ")"

      sOutputBuffer = CryptText

      GoTo Finished

    End If

  End If
 

  'Create a hash object

  If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then

    MsgBox ("Error " & CStr(GetLastError) & " during CryptCreateHash! ")

    GoTo Finished

  End If
 

  'Hash in the password text

  If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then

    MsgBox ("Error " & CStr(GetLastError) & " during CryptHashData!")

    GoTo Finished

  End If
 

  'Create a session key from the hash object

  If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey)) Then

    MsgBox ("Error " & CStr(GetLastError) & " during CryptDeriveKey!")

    GoTo Finished

  End If
 

  'Destroy the hash object.

  CryptDestroyHash (lHHash)

  lHHash = 0
 

  'Prepare sCryptBuffer for CryptDecrypt

  lCryptBufLen = Len(CryptText) * 2

  sCryptBuffer = String(lCryptBufLen, vbNullChar)

  LSet sCryptBuffer = CryptText
 

  'Decrypt data

  If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then

    MsgBox ("bytes required:" & CStr(lCryptBufLen))

    MsgBox ("Error " & CStr(GetLastError) & " during CryptDecrypt!")

    GoTo Finished

  End If
 

  'Setup output buffer with just decrypted data

  sOutputBuffer = Mid$(sCryptBuffer, 1, lCryptBufLen / 2)
 

Finished:

  'Outa here

  DoCryptoDecrypt = sOutputBuffer
 

  'Destroy session key

  If (lHkey) Then lResult = CryptDestroyKey(lHkey)
 

  'Destroy key exchange key handle

  If lHExchgKey Then CryptDestroyKey (lHExchgKey)
 

  'Destroy hash object

  If lHHash Then CryptDestroyHash (lHHash)
 

  'Release Context provider handle

  If lHCryptprov Then lResult = CryptReleaseContext(lHCryptprov, 0)
 

  Exit Function
 

DecryptError:

  MsgBox ("Decrypt Error: " & Error$)

  GoTo Finished

End Function

Open in new window

0
 

Author Closing Comment

by:Mohammad Alsolaiman
ID: 31603644
Wonderful
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

The first two articles in this short series — Using a Criteria Form to Filter Records (http://www.experts-exchange.com/A_6069.html) and Building a Custom Filter (http://www.experts-exchange.com/A_6070.html) — discuss in some detail how a form can be…
In Debugging – Part 1, you learned the basics of the debugging process. You learned how to avoid bugs, as well as how to utilize the Immediate window in the debugging process. This article takes things to the next level by showing you how you can us…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now