title image


Smiley Re: suche gute Dateiverschlüsselung
Ich habe mal eine Klasse erstellt, die Text ver- und entschlüsselt:



Option Explicit



Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal 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 mlngSessionKey As Long, ByVal dwFlags As Long, ByRef 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, ByRef mlngSessionKey As Long) As Long

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

Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal mlngSessionKey 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 CryptDestroyKey Lib "advapi32.dll" (ByVal mlngSessionKey As Long) As Long

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

Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal mlngSessionKey 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 CryptGetKeyParam Lib "advapi32.dll" (ByVal mlngSessionKey As Long, ByVal dwParam As Long, ByVal pbData As String, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long

Private Declare Function CryptSetKeyParam Lib "advapi32.dll" (ByVal mlngSessionKey As Long, ByVal dwParam As Long, ByVal pbData As String, ByVal dwFlags As Long) As Long

Private Declare Function CryptGenRandom Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwLen As Long, ByVal pbBuffer As String) 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 Const SERVICE_PROVIDER As String = "Microsoft Base Cryptographic Provider v1.0" & vbNullChar

Private Const KEY_CONTAINER As String = "Tutorial API" & vbNullChar

Private Const PROV_RSA_FULL As Long = 1

Private Const CRYPT_NEWKEYSET As Long = 8

Private Const CRYPT_DELETEKEYSET As Long = 16

Private Const CRYPT_CREATE_SALT As Long = 4

Private Const CRYPT_EXPORTABLE As Long = 1

Private Const KP_SALT As Long = 2

Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576

Private Const ALG_CLASS_HASH As Long = 32768

Private Const ALG_TYPE_ANY As Long = 0

Private Const ALG_TYPE_STREAM As Long = 2048

Private Const ALG_SID_RC4 As Long = 1

Private Const ALG_SID_MD5 As Long = 3

Private Const ALG_SID_SHA As Long = 4

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

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

Private Const CALG_SHA As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_SHA)

Private Const AT_KEYEXCHANGE As Long = 1

Private Const AT_SIGNATURE As Long = 2

Private Const HP_HASHVAL As Long = 2

Private Const SIMPLEBLOB As Long = 1

Private Const PUBLICKEYBLOB As Long = 6

Private Const PRIVATEKEYBLOB As Long = 7

Private Const CRYPT_NO_SALT As Long = 16

Private Const NTE_BAD_SIGNATURE As Long = -2146893818



Public Event CryptError(ByVal Number As Long, ByVal Description As String)



Private mlngCryptPov As Long

Private mlngSessionKey As Long

Private mstrSalt As String



Private Sub Class_Initialize()

If CryptAcquireContext(mlngCryptPov, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then

If CryptAcquireContext(mlngCryptPov, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then

Call RaiseError("Fehler Beim erstellen des Handles")

End If

End If

End Sub



Private Sub Class_Terminate()

If Not mlngSessionKey = 0 Then CryptDestroyKey mlngSessionKey

If Not mlngCryptPov = 0 Then CryptReleaseContext mlngCryptPov, 0

End Sub



Public Function EncryptString(ByVal Text As String, ByVal Password As String) As String

EncryptString = EnDeCrypt(Text, Password, True)

End Function



Public Function DecryptString(ByVal Text As String, ByVal Password As String) As String

DecryptString = EnDeCrypt(Text, Password, False)

End Function



Private Function EnDeCrypt(ByVal Text As String, ByVal Key As String, ByVal Encrypt As Boolean)

Dim lngLength As Long

Dim lngSALTLen As Long



Call KeyFromPW(Key)



If Encrypt Then

CryptGetKeyParam mlngSessionKey, KP_SALT, vbNull, lngSALTLen, 0

mstrSalt = String(lngSALTLen + 1, vbNullChar)

If CryptGenRandom(mlngCryptPov, lngSALTLen, mstrSalt) = 0 Then

Call RaiseError("SALT konnte nicht berechnet werden!")

Exit Function

End If

End If



CryptSetKeyParam mlngSessionKey, KP_SALT, mstrSalt, 0

If CryptSetKeyParam(mlngSessionKey, KP_SALT, mstrSalt, 0) = 0 Then

Call RaiseError("Konnte SALT nicht setzen.")

Exit Function

End If



lngLength = Len(Text)

If Encrypt Then

If CryptEncrypt(mlngSessionKey, 0, 1, 0, Text, lngLength, lngLength) = 0 Then

Call RaiseError("Fehler während des Encrypt-Vorgangs.")

Exit Function

End If

Else

If CryptDecrypt(mlngSessionKey, 0, 1, 0, Text, lngLength) = 0 Then

Call RaiseError("Fehler während des Decrypt-Vorgangs.")

Exit Function

End If

End If



EnDeCrypt = Left$(Text, lngLength)



If Not mlngSessionKey = 0 Then CryptDestroyKey mlngSessionKey

End Function



Private Sub KeyFromPW(ByVal Key As String)

Dim strHash As String

Dim lngHashLen As Long

Dim lngHash As Long



If CryptCreateHash(mlngCryptPov, CALG_SHA, 0, 0, lngHash) = 0 Then

Call RaiseError("Hash-Objekt kann nicht erstellt werden!")

Exit Sub

End If

If CryptHashData(lngHash, Key, Len(Key), 0) = 0 Then

Call RaiseError("Daten konnten nicht in den Hash geschrieben werden!")

Exit Sub

End If



CryptGetHashParam lngHash, HP_HASHVAL, vbNull, lngHashLen, 0

strHash = String(lngHashLen + 1, vbNullChar)

If CryptGetHashParam(lngHash, HP_HASHVAL, strHash, lngHashLen, 0) = 0 Then

Call RaiseError("Hash-Value ungültig!")

Exit Sub

End If



If Not mlngSessionKey = 0 Then CryptDestroyKey mlngSessionKey

If CryptDeriveKey(mlngCryptPov, CALG_RC4, lngHash, CRYPT_EXPORTABLE, mlngSessionKey) = 0 Then

Call RaiseError("Sessionkey konnte nicht errechnet werden!")

Exit Sub

End If

If Not lngHash = 0 Then CryptDestroyHash lngHash 'Hash zerstören

End Sub



Private Sub RaiseError(ByVal Description As String)

RaiseEvent CryptError(Err.LastDllError, Description)

Err.Clear

End Sub



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: