[Vb6] Creare una stringa/carattere criptata

[Della17]

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

[matpez]

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

[Della17]

grazie

una bella mazuolata di roba

stasera provo e ti dico

[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

[Della17]

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

[matpez]