Algo de cryptage

W czwartek, 28 sierpnia 2003 09:03:12 saulot napisa³/a w wiadomo¶ci
news:3f4daa87$0$6236$626a54ce@news.free.fr

je suis en quête de... en fait je ne sais pas trop... d'un alogorithme de
cryptage fait par microsoft.
En fait, un algo tout ce qu'il y a de plus officiel.
J'ai entendu parler de CryptoAPI mais je ne suis sur de rien.

Si vous aviez des suggestions a me soumettre, j'en serais ravi :)

Je ne me rapelle plus ou je l'ai trouve. Ca marche a merveille!


============================= Option Explicit

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 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, _
ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long

Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hKey As
Long, _
ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal
pbData As String, _
ByRef pdwDataLen As Long) As Long

Private Declare Function 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 CryptReleaseContext Lib "advapi32.dll" (ByVal
hProv As Long, _
ByVal dwFlags 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, ByRef pcbProvName As Long) As Long

Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash
As Long, _
ByVal dwParam As Long, ByVal pbData As String, ByRef pdwDataLen As
Long, ByVal dwFlags As Long) As Long

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

'Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL As Long = 1
Private Const CRYPT_NEWKEYSET As Long = 8

Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_RC2 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_TYPE_BLOCK As Long = 1536
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const CALG_MD5 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or
ALG_SID_MD5)
Private Const CALG_RC2 As Long = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK
Or ALG_SID_RC2)
Private Const CALG_RC4 As Long = (ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM
Or ALG_SID_RC4)

Private Const CRYPT_MACHINE_DEFAULT As Long = 1
Private Const CRYPT_USER_DEFAULT As Long = 2
Private Const HP_HASHVAL As Long = 2

Public Enum edEncryptAlgorithm
edRC2 = CALG_RC2
edRC4 = CALG_RC4
End Enum

Private Const lErrorBase As Long = vbObjectError
Private Const sModuleName As String = "EncryptDecrypt"

Private Sub RaiseError(Optional Description As String)
Err.Clear
Err.Raise lErrorBase, sModuleName, Description
End Sub

Public Property Get DefaultProvider() As Variant
Dim sProvName As String
Dim lProvBufLen As Long
sProvName = vbNullString
DefaultProvider = Null
On Error GoTo error 'in case CryptGetDefaultProvider function is not
implemented ... (eg. NT 4.0)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&,
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
sProvName = String(lProvBufLen, vbNullChar)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&,
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
DefaultProvider = Left$(Left$(sProvName, lProvBufLen), InStr(1,
Mid(sProvName, 1, lProvBufLen), vbNullChar) - 1)
error:
End Sub

Public Property Get DefaultProvider2() As Variant
Dim sProvName As String
Dim lProvBufLen As Long
sProvName = vbNullString
DefaultProvider = Null
On Error GoTo error 'in case CryptGetDefaultProvider function is not
implemented ... (eg. NT 4.0)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&,
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
sProvName = String(lProvBufLen, vbNullChar)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&,
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
DefaultProvider2 = Left$(Left$(sProvName, lProvBufLen), InStr(1,
Mid(sProvName, 1, lProvBufLen), vbNullChar) - 1)
error:
End Property

Public Function Encrypt(ByVal text, ByVal Password As String, Optional
EncryptAlgorithm As edEncryptAlgorithm = edRC2) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lAlgid As Long
Dim sContainer As String
Dim sProvider As String
Dim sData As String
Dim lDataLen As Long
Dim lBufLen As Long
Dim sText As String
Dim sPassword As String

If IsNull(text) Then
Encrypt = Null: Exit Function
ElseIf text = "" Then
Encrypt = "": Exit Function
ElseIf LCase(TypeName(text)) <> "string" Then
Err.Clear: Err.Raise lErrorBase, sModuleName, "argument of wrong type"
Exit Function
End If
lAlgid = EncryptAlgorithm
sText = text
sPassword = Password

'Get handle to the default provider
sContainer = vbNullString
sProvider = vbNullString
If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
'Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
'Hash in the password data.
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
'Derive a session key from the hash object.
If Not CBool(CryptDeriveKey(lHProv, lAlgid, lHHash, 0, lHkey)) Then
RaiseError "error during CryptDeriveKey"
GoTo error
End If
'Destroy the hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
lHHash = 0

lDataLen = Len(sText)
lBufLen = lDataLen
If lAlgid And ALG_TYPE_BLOCK = ALG_TYPE_BLOCK Then
sData = vbNullString
lResult = CryptEncrypt(lHkey, 0, 1, 0, sData, lDataLen, lBufLen)
lBufLen = lDataLen
lDataLen = Len(sText)
End If
sData = String(lBufLen, vbNullChar)
LSet sData = sText
If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sData, lDataLen, lBufLen)) Then
RaiseError "error during CryptEncrypt"
GoTo error
End If

'return encrypted string
Encrypt = Left$(sData, lDataLen)

error:
'Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
'Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
'Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function

Public Function Decrypt(ByVal text, ByVal Password, Optional
EncryptAlgorithm As edEncryptAlgorithm = edRC2) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lAlgid As Long

Dim sContainer As String
Dim sProvider As String

Dim sData As String
Dim lBufLen As Long
Dim lCryptPoint As Long

Dim lPasswordPoint As Long
Dim lPasswordCount As Long
Dim sText As String
Dim sPassword As String

If IsNull(text) Then
Decrypt = Null: Exit Function
ElseIf text = "" Then
Decrypt = "": Exit Function
ElseIf LCase(TypeName(text)) <> "string" Then
RaiseError "argument of wrong type"
Decrypt = Null
Exit Function
End If
lAlgid = EncryptAlgorithm
sText = text
sPassword = Password

'Get handle to the default provider.
sContainer = vbNullString
sProvider = vbNullString
If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
'Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
'Hash in the password data.
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
'Derive a session key from the hash object.
If Not CBool(CryptDeriveKey(lHProv, lAlgid, lHHash, 0, lHkey)) Then
RaiseError "error during CryptDeriveKey"
GoTo error
End If
'Destroy the hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
lHHash = 0
'Prepare sData for CryptDecrypt
lBufLen = Len(sText)
sData = sText
'Decrypt data
If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sData, lBufLen)) Then
RaiseError "error during CryptDecrypt"
GoTo error
End If
'return decrypted string
Decrypt = Left$(sData, lBufLen)

error:
'Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
'Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
'Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function

Public Function HashData(ByVal text) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim sContainer As String
Dim sProvider As String
Dim sData As String
Dim lDataLen As Long
Dim sText As String

If IsNull(text) Then HashData = Null: Exit Function
If LCase(TypeName(text)) <> "string" Then
RaiseError "argument of wrong type"
HashData = Null
Exit Function
End If

sText = text
sContainer = vbNullString
sProvider = vbNullString

If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, sProvider,
PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
'Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
'Hash in data.
If Not CBool(CryptHashData(lHHash, sText, Len(sText), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
'Get hash value.
sData = vbNullString
If Not CBool(CryptGetHashParam(lHHash, HP_HASHVAL, sData, lDataLen, 0))
Then
RaiseError "error during CryptGetHashParam"
GoTo error
End If
'sData = String(16, lDataLen)
sData = String(lDataLen, vbNullChar)
If Not CBool(CryptGetHashParam(lHHash, HP_HASHVAL, sData, lDataLen, 0))
Then
RaiseError "error during CryptGetHashParam"
GoTo error
End If

HashData = Left$(sData, lDataLen)

error:
'Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
'Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
'Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function



--
Pozdrawiam - Adam Pietrasiewicz
Go³±bek - Koniec z krzakami - prawdziwie polski klient mail/news
http://www.amsoft.com.pl/golabek/pomoc/

Hello!

Tu trouveras quelques références dans la MSDN:
http://msdn.microsoft.com/library/en-us/dncapi/html/msdn_cryptapi.asp

Et encore bien plus dans le platform SDK:
http://www.microsoft.com/msdownload/platformsdk/sdkupdate/

--
François Picalausa (MVP VB)
FAQ VB : http://faq.vb.free.fr
MSDN : http://msdn.microsoft.com


"saulot" <wesley.saris@inter-informatique.ch> a écrit dans le message
de news:3f4daa87$0$6236$626a54ce@news.free.fr

Bonjour,
je suis en quête de... en fait je ne sais pas trop... d'un
alogorithme de cryptage fait par microsoft.
En fait, un algo tout ce qu'il y a de plus officiel.
J'ai entendu parler de CryptoAPI mais je ne suis sur de rien.

Si vous aviez des suggestions à me soumettre, j'en serais ravi :)

merci