'Source: http://www.mentalis.org/
'Class module (CLSCryptofilterbox)
Option ExplicitPrivate 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 LongPrivate 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 LongPrivate 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 LongPrivate Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As LongPrivate Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPrivate 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 LongPrivate Declare Function CryptDecry pt 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 LongPrivate 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 String, pdwDataLen As Long) As LongPrivate Declare Function CryptGenKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, Byval dwflags as long, phkey as long) As longprivate 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 LongPrivate Declare Function CryptGetUserKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwKeySpec As Long, phUserKey As Long) As LongPrivate Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As LongPrivate Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As LongPrivate Declare Function CryptSignHash Lib "advapi32.dll" Alias "CryptSignHashA" (ByVal hHash As Long, ByVal dwKeySpec As Long, ByVal sDescription As String, ByVal dwFlags As Long, ByVal pbSignature As String, pdwSigLen As Long) As LongPrivate Declare Function CryptVerifySignature Lib "advapi32.dll" Alias "CryptVerifySignatureA" (ByVal hHash As Long, ByVal pbSignature As String, ByVal dwSigLen As Long, ByVal hPubKey As Long, ByVal sDescription As String, ByVal dwFlags As Long) As long'api error functionprivate declare function getLastError lib "kernel32" () AS Long
'API memory functionsPrivate Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPrivate Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Sub CpyMemValAdrFromRefAdr Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) Private Declare Sub CpyMemRefAdrFromValAdr Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy As Long) 'constants for API memory functionsPrivate Const GMEM_MOVEABLE = & H2Private Const GMEM_ZEROINIT = & H40Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
'Constants for Cryptography API functionsPrivate Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0" Private Const PROV_RSA_FULL = 1Private Const CRYPT_NEWKEYSET = & H8Private Const PP_CONTAINER = 6Private Const AT_KEYEXCHANGE = 1Private Const AT_SIGNATURE = 2
Private const simpleblob = 1
Private Const ALG_CLASS_DATA_ENCRYPT = 24576Private Const ALG_CLASS_HASH = 32768Private Const ALG_TYPE_ANY = 0Private Const ALG_TYPE_BLOCK = 1536Private Const ALG_TYPE_STREAM = 2048Private Const ALG_SID_RC2 = 2Private Const ALG_SID_RC4 = 1Private 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) 'constants from WinErr.hPrivate Const NTE_NO_KEY As Long = -2146893811 '0x8009000dlprivate const nTE_BAD_SIGNATURE As long = -2146893818
'clscryptofilterbox constantsprivate const cfb_busy = 0Private const cfb_ready = 1private const cfb_valid = 2
Private const encrypt_algorithm = calg_rc4private const encrypt_block_size = 1
Private const crypt_exportable = 1
'Private property buffersPrivate sInBuffer As StringPrivate sOutBuffer As StringPrivate sPassword As StringPrivate sSignature As StringPrivate lStatus As LongPublic Property Get InBuffer () As String InBuffer = sInBufferEnd PropertyPublic Property Let InBuffer (vNewValue As String) sInBuffer = vNewValueEnd PropertyPublic Property Get OutBuffer () As String OutBuffer = sOutBufferEnd PropertyPublic Property Get Signature () As String Signature = sSignatureEnd PropertyPublic Property Let Signature (vNewValue As String) sSignature = vNewValueEnd PropertyPublic Sub Sign () 'Create a signature for Inbuffer and place in Signature
Dim Scontainer AS String, SDESCRIPTION As String, SPROVIDER AS STRING, LHCRYPTPROV AS Longdim Lhhash As Long, LRESULT AS Long, LSIGNATURELEN As Long
ON Error Goto Errsign
'Switch Status Propertylstatus = CFB_BUSY
'Init Signature Propertyssignature = ""
'Get handle to the default provider.sContainer = vbNullCharsProvider = MS_DEF_PROV & vbNullCharIf Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then MsgBox ( "Error" & CStr (GetLastError) & "during CryptAcquireContext!" ) GoTo ReleaseHandles: End If'Create a hash object.If Not CBool (CryptCreateHash (lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then MsgBox ( "Error" & CStr (GetLastError) & "during CryptCreateHash!") GoTo ReleaseHandles: END IF
IF NOT CBOOL (crypthashdata (lhhash, sinbuffer, lin (sinbuffer), 0)) THEN MSGBOX ("Error" & CSTR (GetLastError) & "During CrypthashData!")
'Sign Hash Object.'deetermine Size of Signature.SDescription = VBnullCharlResult = Cryptsignhash (lhhash, at_signature, sdescription, 0, ssideature, lsignaturelen)
Ssignature = String (lsignaturelen, vbnullchar)
'Sign hash object (with signature key) .If Not CBool (CryptSignHash (lHHash, AT_SIGNATURE, sDescription, 0, sSignature, lSignatureLen)) Then MsgBox ( "Error" & CStr (GetLastError ()) & "during CryptSignHash") GoTo ReleaseHandles : END IF
ReleaseHandles: 'Destroy Hash Object.if lhhash Then Lresult = Cryptdestroyhash (lhhash)' Release Provider Handle.if lhcryptProv Then LRESULT = CRYPTRELEASECONTEXT (LHCRYPTPROV, 0)
'Switch Status Propertylstatus = Cfb_ready
EXIT SUB
ErrSign: MsgBox ( "ErrSign" & Error $) GoTo ReleaseHandlesEnd SubPublic Sub Validate () 'Validate InBuffer with Signature and assign Status with resultDim bValid As Boolean, sContainer As String, sDescription As String, sProvider As StringDim lDataLen As Long, lDataPoint As Long , lHCryptprov As Long, lHHash As LongDim lResult As Long, lSignatureLen As Long, lHCryptKey As LongReDim aByteData (0) As ByteOn Error GoTo ErrValidate'switch Status propertylStatus = CFB_BUSY'init internal valid flagbValid = True'Get handle to the default provider.sContainer = vbNullCharsProvider = MS_DEF_PROV & vbNullCharIf Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then bValid = False MsgBox ( "Error" & CStr (GetLastError) & "during CryptAcquireContext!") GoTo ReleaseHandles: End If 'Create a Hash Object.if Not CBool (cryptcreatehash (lhcryptprov, calg_md5, 0, 0, lhhash) THEN BVALID = FALSE MSGBOX ("ERROR" & CSTRES & "DURING CRYPTCREATE Hash! ") Goto ReleaseHandles: Endness.if Not Cbool (crypthashdata (lhhash, sinbuffer, len (sinbuffer), 0)) Then bvalid = false msgbox (" Error "& cstr (getLastError) &" during CryptHashData ") GoTo ReleaseHandles:! End If'Determine size of signature.'sDescription = vbNullChar'lResult = CryptSignHash (lHHash, AT_SIGNATURE, sDescription, 0, 0, lSignatureLen) 'Get handle to signature key.If Not CBool (CryptGetUserKey ( LHCryptProv, At_Signature, LHCryptKey) The bvalid = false msgbox ("Error" & CSTR (GetLastError) & "
during CryptGetUserKey ") GoTo ReleaseHandles:! End IflSignatureLen = Len (sSignature) 'Verify signature.If Not CBool (CryptVerifySignature (lHHash, sSignature, lSignatureLen, lHCryptKey, sDescription, 0)) Then If GetLastError = NTE_BAD_SIGNATURE Then bValid = False GoTo ReleaseHandles: Else bValid = False MsgBox ( "Error" & CStr (GetLastError) & "! during CryptVerifySignature") GoTo ReleaseHandles: End IfEnd IfReleaseHandles: 'Release signature key.If lHCryptKey Then lResult = CryptDestroyKey (lHCryptKey)' Destroy hash object.If lHHash Then lResult = CryptDestroyHash (lHHash) 'Release provider handle.If lHCryptprov Then lResult = CryptReleaseContext (lHCryptprov, 0) Select Case bValid Case True lStatus = CFB_VALID Case Else lStatus = CFB_READYEnd SelectExit SubErrValidate: MsgBox ( "ErrValidate" & Error $) ResumeEnd SubPublic Sub Encrypt () 'Encrypt Inbuffer Into Outbufferdim Lhexchgkey As Long, Lhhash As Long, Lhkey AS Longdim Lresult As Long, Scontainer AS String, Sprovider AS String, Scryptbuff AS Stringdim Lcryptlength As Long, LcryptBuflen As Long
ON Error Goto Errencrypt
'Switch Status Propertylstatus = CFB_BUSY
'Get handle to the default providersContainer = vbNullCharsProvider = vbNullCharsProvider = MS_DEF_PROV & vbNullCharIf Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then MsgBox ( "Error" & CStr (GetLastError) & "during CryptAcquireContext!" ) GOTO DONEEND IF
'Create a hash object.If Not CBool (CryptCreateHash (lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then MsgBox ( "Error" & CStr (GetLastError) & "during CryptCreateHash!") GoTo DoneEnd If'Hash in the password data .IF Not CBool (CrypthashData (Lhhash, Spassword, 0)) The MsgBox ("Error" & CSTR (GetLastError) & "During CrypthashData!") Goto Doneend IF
'Derive 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 DoneEnd If
'Destroy the hash object.cryptdestroyhash (lhhash) lhhash = 0
'Prepare a string buffer for the CryptEncrypt functionlCryptLength = Len (sInBuffer) lCryptBufLen = lCryptLength * 2sCryptBuffer = String (lCryptBufLen, vbNullChar) LSet sCryptBuffer = sInBuffer
'Encrypt dataIf Not CBool (CryptEncrypt (lHkey, 0, 1, 0, sCryptBuffer, lCryptLength, lCryptBufLen)) Then MsgBox ( "bytes required:" & CStr (lCryptLength)) MsgBox ( "Error" & CStr (GetLastError) & "during Cryptencrypt! ") 'Goto Doneend IF
Soutbuffer = MID $ (ScryptBuffer, 1, LcryptLength)
DONE:
'Destroy Session Key.if (Lhkey) THEN LRESULT = CRYPTDESTROYKEY (LHKEY)
'Release Key Exchange Key Handle.if Lhexchgkey Then CryptDestroyKey (LHEXCHGKEY)
'Destroy Hash Object.if lhhash Then Cryptdestroyhash (lhhash)
'Release Provider Handle.if lhcryptProv Then LRESULT = CRYPTRELESECONTEXT (LHCRYPTPROV, 0)
'Switch Status Propertylstatus = Cfb_ready
EXIT SUB
Errencrypt:
MsgBox ( "ErrEncrypt" & Error $) ResumeEnd SubPublic Sub Decrypt () 'Decrypt InBuffer into OutBufferDim lHExchgKey As Long, lHCryptprov As Long, lHHash As Long, lHkey As LongDim lResult As Long, sContainer As String, sProvider As StringDim sCryptBuffer As String, LcryptBuflen As Long, LcryptPoint As Longdim LPasswordPoint As Long, LPasswordCount As Long
ON Error Goto Errdecrypt
'Switch Status Propertylstatus = CFB_BUSY
'Init snoutbuffersoutbuffer = ""
'Get handle to the default provider.sContainer = vbNullCharsProvider = vbNullCharsProvider = MS_DEF_PROV & vbNullCharIf Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then MsgBox ( "Error" & CStr (GetLastError) & "during CryptAcquireContext ! ") Goto Donend IF
'Create a Hash Object.if Not CBool (cryptcreatehash (Cryptcreatehash (Calg_MD5, 0, 0, Lhhash)) THEN MSGBOX ("Error" & CSTERRROR & "DURING CRYPTCREATEHASH!") Goto Doneend IF
'Hash in the password data.if Not CBool (CrypthashData (Lhhash, Spassword, Len (Spassword), 0)) THEN MSGBOX ("Error" & CSTERRROR & "DURING CRYPTHASHDATA!") Goto Doneend IF
'Derive 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 DoneEnd If
'Destroy the hash object.cryptdestroyhash (lhhash) lhhash = 0
'Prepare sCryptBuffer for CryptDecryptlCryptBufLen = Len (sInBuffer) * 2sCryptBuffer = String (lCryptBufLen, vbNullChar) LSet sCryptBuffer = sInBuffer'Decrypt dataIf Not CBool (CryptDecrypt (lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then MsgBox ( "bytes required : "& CSTR (LcryptBuflen) MsgBox (" Error "& CSTR (GetLastError) &" During CryptDecrypt! ") Goto Doneend IF
'Apply Decrypted String from ScryptBuffer To Private Buffer for Outbuffer PropertySoutBuffer = MID $ (ScryptBuffer, 1, Len (Sinbuffer)
DONE:
'Destroy Session Key.if (Lhkey) THEN LRESULT = CRYPTDESTROYKEY (LHKEY)
'Release Key Exchange Key Handle.if Lhexchgkey Then CryptDestroyKey (LHEXCHGKEY)
'Destroy Hash Object.if lhhash Then Cryptdestroyhash (lhhash)
'Release Provider Handle.if lhcryptProv Then LRESULT = CRYPTRELESECONTEXT (LHCRYPTPROV, 0)
'Switch Status Propertylstatus = Cfb_ready
EXIT SUB
Errdecrypt: Msgbox ("Errdecrypt" & Error $) GOTO DONE
End SubPublic Property Get Status () As Long Status = lStatusEnd PropertyPrivate Function InitUser () As Long Dim lHCryptprov As Long, lHCryptKey As Long, avProviderData (1000) As Byte Dim lProviderDataAddress As Long, lProviderDataLen As Long, lDataSize As Long Dim lResult As Long SCONTAINER AS STRING, SPROVIDER AS STRING DIM SUSERNAME AS STRING, LPOINT AS Long, LMemHandle As Long Dim Lreturn As Long, SBuffer AS String
ON Error Goto ErrinitUser 'Prepare String Buffers
Scontainer = vbnullchar sprovider = ms_def_prov & vbnullchar
'Attempt to acquire a handle to the default key container. If Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal sProvider, PROV_RSA_FULL, 0)) Then'Create default key container. If Not CBool (CryptAcquireContext (lHCryptprov, ByVal sContainer, ByVal SPROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) The MsgBox ("Error Creating Key Container & CSTR (Getlasterror) EXIT FUNCTION END IF
'Get name of default key container. LProviderDataLen = Len (avProviderData (0)) * (UBound (avProviderData) 1) If Not CBool (CryptGetProvParam (lHCryptprov, PP_CONTAINER, avProviderData (0), lProviderDataLen, 0)) Then MsgBox ( " Error getting user name! "& Cstr (getLasteError)) avProviderData (0) = 0 end if
'Get sUserName from avProviderData () lPoint = LBound (avProviderData) While lPoint <= UBound (avProviderData) If avProviderData (lPoint) <> 0 Then sUserName = sUserName & Chr $ (avProviderData (lPoint)) Else lPoint = UBound (avProviderData) End If lpoint = lpoint 1 Wend
Msgbox ("Create Key Container & SuserName)
END IF
'Attempt to get handle to signature key If Not CBool (CryptGetUserKey (lHCryptprov, AT_SIGNATURE, lHCryptKey)) Then If GetLastError = NTE_NO_KEY Then MsgBox ( "Create key exchange key pair") If Not CBool (CryptGenKey (lHCryptprov, AT_SIGNATURE, 0, lHCryptKey )) Then MsgBox ( "Error during CryptGenKey!" & CStr (GetLastError)) Exit Function Else lResult = CryptDestroyKey (lHCryptprov) End If Else MsgBox ( "Error during CryptGetUserKey!" & CStr (GetLastError)) Exit Function End If End If ' Attempt to get handle to exchange key If Not CBool (CryptGetUserKey (lHCryptprov, AT_KEYEXCHANGE, lHCryptKey)) Then If GetLastError = NTE_NO_KEY Then MsgBox ( "Create key exchange key pair") If Not CBool (CryptGenKey (lHCryptprov, AT_KEYEXCHANGE, 0, lHCryptKey) ) THEN MSGBOX ("Error During CryptGenkey!" & Cstr (getLastError)) EXIT FUNCTION ELSE LRESULT = CRYPTDESTROYKEY (LHCRYPTPROV) END IF ELSE MSGBOX ("ERROR DURING CRYPTGETUSERKEY! & Cstr (getLastError) EXIT FUNCTION END IF END IF
'Release Handle to Provider Lresult = CryptreleaseContext (LHCRYPTPROV, 0) Inituser = TRUE
EXIT FUNCTION
Errinituser: Msgbox ("Errinituser" & Error $) Resume
