Buondė avrei bisogno per un programmino che sto facendo,di salvare una pass su un file di testo,ma vorrei che questa pass fosse criptata o non leggibile quando si apre il file di testo con un editor qualsiasi...mi spiego meglio vorrei sapere se esiste in vb una funzione o un comando simile al encode/decode di mysql :) ;)
grazie per le risposte
Ecco a te tutto quello che ti serve :)
Option Explicit
Private Const CRYPT_NEWKEYSET As Long = &H8
Private Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL As Long = 1
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 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 ENCRYPT_ALGORITHM As Long = CALG_RC4
Private Declare Function CryptAcquireContext Lib "Advapi32.dll" Alias "CryptAcquireContextA" (phProv As Long, ByVal pszContainer As Long, 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 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
Public Function EncryptAPI(ByVal sTesto As String, ByVal sChiave As String, Optional ByVal bUUEncoding As Boolean = False) As String
'Cripta il testo specificato con le API.
On Error Resume Next
Dim lHHash As Long
Dim lHkey As Long
Dim lHExchgKey As Long
Dim lHCryptprov As Long
Dim lCryptLength As Long
Dim lCryptBufLen As Long
Dim lngRet As Long
Dim sCryptBuffer As String
Dim sProvider As String
If sTesto = "" Then Exit Function
sProvider = MS_DEF_PROV & vbNullChar
lngRet = CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, 0)
If lngRet = 0 Then
lngRet = CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)
End If
If lngRet Then
If CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash) Then
If CryptHashData(lHHash, sChiave, Len(sChiave), 0) Then
If CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey) Then
CryptDestroyHash (lHHash)
lHHash = 0
lCryptLength = Len(sTesto)
lCryptBufLen = lCryptLength * 2
sCryptBuffer = String$(lCryptBufLen, vbNullChar)
LSet sCryptBuffer = sTesto
If CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptLength, lCryptBufLen) Then
sCryptBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
If bUUEncoding Then
sCryptBuffer = UUEncode(sCryptBuffer)
End If
EncryptAPI = sCryptBuffer
End If
End If
End If
End If
End If
If Err.LastDllError Then Err = Err.LastDllError
If lHkey Then Call CryptDestroyKey(lHkey)
If lHExchgKey Then CryptDestroyKey (lHExchgKey)
If lHHash Then CryptDestroyHash (lHHash)
If lHCryptprov Then Call CryptReleaseContext(lHCryptprov, 0)
End Function
Public Function DecryptAPI(ByVal sTesto As String, ByVal sChiave As String, Optional ByVal bUUDecode As Boolean = False) As String
'Decripta il testo specificato con le API.
On Error Resume Next
Dim lHExchgKey As Long
Dim lHCryptprov As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lCryptBufLen As Long
Dim sProvider As String
Dim sCryptBuffer As String
If sTesto = "" Then Exit Function
If bUUDecode Then
sTesto = UUDecode(sTesto)
End If
sProvider = vbNullChar
sProvider = MS_DEF_PROV & vbNullChar
If CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, 0) Then
If CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash) Then
If CryptHashData(lHHash, sChiave, Len(sChiave), 0) Then
If CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey) Then
CryptDestroyHash (lHHash)
lHHash = 0
lCryptBufLen = Len(sTesto) * 2
sCryptBuffer = String$(lCryptBufLen, vbNullChar)
LSet sCryptBuffer = sTesto
If CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen) Then
DecryptAPI = Mid$(sCryptBuffer, 1, lCryptBufLen / 2)
End If
End If
End If
End If
End If
If Err.LastDllError Then Err = Err.LastDllError
If (lHkey) Then Call CryptDestroyKey(lHkey)
If lHExchgKey Then CryptDestroyKey (lHExchgKey)
If lHHash Then CryptDestroyHash (lHHash)
If lHCryptprov Then Call CryptReleaseContext(lHCryptprov, 0)
End Function
Private Function UUEncode(ByVal InputBuffer As String) As String
On Error Resume Next
Dim bytChar() As Byte
Dim bytBuffer() As Byte
Dim intStrPos As Integer
Dim strOutBuffer As String
Dim nLen As Integer
nLen = Len(InputBuffer)
For intStrPos = 1 To nLen Step 3
bytBuffer = StrConv(Mid$(InputBuffer, intStrPos, 3), vbFromUnicode)
ReDim Preserve bytChar(IIf(UBound(bytBuffer) = 3, 3, UBound(bytBuffer) + 1))
If UBound(bytBuffer) < 3 Then ReDim Preserve bytBuffer(UBound(bytBuffer) + 1)
bytChar(0) = Int(bytBuffer(0) / 4)
bytChar(0) = IIf(bytChar(0), (bytChar(0) And 63) + 32, 96)
bytChar(1) = ((bytBuffer(0) * 16) And 48) Or (Int(bytBuffer(1) / 16) And 15)
bytChar(1) = IIf(bytChar(1), (bytChar(1) And 63) + 32, 96)
bytChar(2) = ((bytBuffer(1) * 4) And 60) Or (Int(bytBuffer(2) / 64) And 3)
bytChar(2) = IIf(bytChar(2), (bytChar(2) And 63) + 32, 96)
bytChar(3) = (bytBuffer(2) And 63)
bytChar(3) = IIf(bytChar(3), (bytChar(3) And 63) + 32, 96)
strOutBuffer = strOutBuffer & StrConv(bytChar, vbUnicode)
Next
UUEncode = strOutBuffer
Err.Clear
End Function
Private Function UUDecode(ByVal InputBuffer As String) As String
On Error Resume Next
Dim bytChar() As Byte
Dim intLen As Integer
Dim strOutBuffer As String
Dim intFill As Integer
intLen = 1
intFill = Len(InputBuffer) Mod 4
InputBuffer = InputBuffer & String$(intFill, "`")
Do While intLen <= Len(InputBuffer)
bytChar = StrConv(Mid$(InputBuffer, intLen, 4), vbFromUnicode)
ReDim Preserve bytChar(3)
strOutBuffer = strOutBuffer & Chr$(((((bytChar(0) - 32) And 63) * 4) Or Int(((bytChar(1) - 32) And 63) / 16)) And &HFF)
strOutBuffer = strOutBuffer & Chr$(((((bytChar(1) - 32) And 63) * 16) Or Int(((bytChar(2) - 32) And 63) / 4)) And &HFF)
strOutBuffer = strOutBuffer & Chr$(((((bytChar(2) - 32) And 63) * 64) Or ((bytChar(3) - 32) And 63)) And &HFF)
intLen = intLen + 4
Loop
Select Case intFill
Case 1
UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill)
Case 2
UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill)
Case 3
UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill - 1)
Case Else
UUDecode = strOutBuffer
End Select
Err.Clear
End Function
grazie :)
una bella mazuolata di roba :D
stasera provo e ti dico ;)
Se lo metti dentro un modulo (.bas), tutte le funzioni Public le vedi, il resto nn lo vedi.. cosė hai comodo comodo le funzioni di Codifica e di Decodifica senza vedere altra porcheria :)
Originariamente inviato da matpez
Se lo metti dentro un modulo (.bas), tutte le funzioni Public le vedi, il resto nn lo vedi.. cosė hai comodo comodo le funzioni di Codifica e di Decodifica senza vedere altra porcheria :)
:) grazie avevo intenzione di farlo ;)
vBulletin® v3.6.4, Copyright ©2000-2025, Jelsoft Enterprises Ltd.