Newsgroup: it.comp.appl.access
Titolo: controllo criteri nuova password di accesso

Buon pomeriggio.
Per la prima volta posto un codice già (almeno sembra) funzionante.
Sicuramente è un po' spartano e si può racchiudere in meno righe di codice.
La password deve contenere una Maiuscola, una Minuscola, un Numero e un carattere speciale.
Di seguito il codice, attendo vs. giudizi e consigli/miglioramenti.
Private Sub txtPassword_Exit(Cancel As Integer)
 
Dim i As Integer
Dim strNumero As String
Dim strMaiuscolo As String
Dim strMinuscolo As String
Dim strSpeciale As String
    strOut = ""
    strTemp = ""
 
    For i = 1 To Len(Me.txtPassword)
    strTemp = Mid(Me.txtPassword, i, 1)
    If strNumero <> "OK" Then 'Se già presente un numero salta il controllo
        If IsNumeric(strTemp) Then
            strNumero = "OK"
        Else
            If strNumero <> "OK" Then
                If i = Len(Me.txtPassword) And Not IsNumeric(strTemp) Then
                    MsgBox "La password deve contenere almeno un numero!", vbCritical, "ORION"
                    Me.txtPassword = Null
                    Exit Sub
                End If
            End If
        End If
    End If
    If strMaiuscolo <> "OK" Then 'Se già presente una maiuscola salta il controllo
        If Asc(strTemp) >= 65 And Asc(strTemp) <= 90 Then
            strMaiuscolo = "OK"
        Else
            If strMaiuscolo <> "OK" Then
                If i = Len(Me.txtPassword) And Asc(strTemp) < 90 Then
                    MsgBox "La password deve contenere almeno un carattere maiuscolo!", vbCritical, "ORION"
                    Me.txtPassword = Null
                    Exit Sub
                End If
            End If
        End If
    End If
    If strMinuscolo <> "OK" Then 'Se già presente una minuscola salta il controllo
        If Asc(strTemp) >= 97 And Asc(strTemp) <= 122 Then
            strMinuscolo = "OK"
        Else
            If strMinuscolo <> "OK" Then
                If i = Len(Me.txtPassword) And Asc(strTemp) < 97 Then
                    MsgBox "La password deve contenere almeno un carattere minuscolo!", vbCritical, "ORION"
                    Me.txtPassword = Null
                    Exit Sub
                End If
            End If
        End If
    End If
    If strSpeciale <> "OK" Then 'Se già presente un carattere speciale salta il controllo
        If Asc(strTemp) = 47 Or Asc(strTemp) = 42 Or Asc(strTemp) = 45 Or Asc(strTemp) = 43 Or Asc(strTemp) = 63 Or Asc(strTemp) = 64 Or Asc(strTemp) = 95 Or Asc(strTemp) = 35 Then
            strSpeciale = "OK"
        Else
            If strSpeciale <> "OK" Then
                If i = Len(Me.txtPassword) And (Asc(strTemp) <> 47 Or Asc(strTemp) <> 42 Or Asc(strTemp) <> 45 Or Asc(strTemp) <> 43 Or Asc(strTemp) <> 63 Or Asc(strTemp) <> 64 Or Asc(strTemp) <> 95 Or Asc(strTemp) <> 35) Then
                    MsgBox "La password deve contenere almeno un carattere speciale!", vbCritical, "ORION"
                    Me.txtPassword = Null
                    Exit Sub
                End If
            End If
        End If
    End If
    Next
    If strNumero = "OK" And strMaiuscolo = "OK" And strMinuscolo = "OK" And strSpeciale = "OK" Then
        MsgBox "Password creata con successo ", vbInformation, "ORION"
    Else
        MsgBox "La password non rispetta i criteri", vbCritical, "ORION"
        Me.txtPassword = Null
        Me.txtPassword.SetFocus
    End If
End Sub
 
 
Private Sub txtPassword_OLD_AfterUpdate()
'    If Len(Me.txtPassword.Text) < 8 Then
'        MsgBox "La password deve contenere almeno 8 caratteri!", vbCritical, "ORION"
'        Me.txtPassword = Null
'        Exit Sub
'    End If
 
' DA COMPLETARE: CON IL CODICE SOTTO TROVA IL NUMERO NELLA PASSWORD
Dim strOut
Dim strTemp
Dim i As Integer
 
Dim strNumero As String
Dim strMaiuscolo As String
Dim strMinuscolo As String
Dim strSpeciale As String
    strOut = ""
    strTemp = ""
 
    For i = 1 To Len(Me.txtPassword)
    strTemp = Mid(Me.txtPassword, i, 1)
    If strNumero <> "OK" Then
        If IsNumeric(strTemp) Then
            strNumero = "OK"
    '        strOut = strOut & strTemp
            ' appena trova un numero esce dal ciclo
    '        Exit For
        Else
            If strNumero <> "OK" Then
                If i = Len(Me.txtPassword) And Not IsNumeric(strTemp) Then
                    MsgBox "La password deve contenere almeno un numero!", vbCritical, "ORION"
                    Exit Sub
                End If
            End If
        End If
    End If
    If strMaiuscolo <> "OK" Then
        If Asc(strTemp) >= 65 And Asc(strTemp) <= 90 Then
            strMaiuscolo = "OK"
    '        strOut = strOut & strTemp
            ' appena trova un carattere maiuscolo esce dal ciclo
    '        Exit For
        Else
            If strMaiuscolo <> "OK" Then
                If i = Len(Me.txtPassword) And Asc(strTemp) > 90 Then
                    MsgBox "La password deve contenere almeno un carattere maiuscolo!", vbCritical, "ORION"
                    Exit Sub
                End If
            End If
        End If
    End If
    If strMinuscolo <> "OK" Then
        If Asc(strTemp) >= 97 And Asc(strTemp) <= 122 Then
            strMinuscolo = "OK"
    '        strOut = strOut & strTemp
            ' appena trova un carattere minuscolo esce dal ciclo
    '        Exit For
        Else
            If strMinuscolo <> "OK" Then
                If i = Len(Me.txtPassword) And Asc(strTemp) < 97 Then
                    MsgBox "La password deve contenere almeno un carattere minuscolo!", vbCritical, "ORION"
                    Exit Sub
                End If
            End If
        End If
    End If
    If strSpeciale <> "OK" Then
        If Asc(strTemp) = 47 Or Asc(strTemp) = 42 Or Asc(strTemp) = 45 Or Asc(strTemp) = 43 Or Asc(strTemp) = 63 Or Asc(strTemp) = 64 Or Asc(strTemp) = 95 Or Asc(strTemp) = 35 Then
            strSpeciale = "OK"
    '        strOut = strOut & strTemp
            ' appena trova un carattere Speciale esce dal ciclo
    '        Exit For
        Else
            If strSpeciale <> "OK" Then
                If i = Len(Me.txtPassword) And (Asc(strTemp) <> 47 Or Asc(strTemp) <> 42 Or Asc(strTemp) <> 45 Or Asc(strTemp) <> 43 Or Asc(strTemp) <> 63 Or Asc(strTemp) <> 64 Or Asc(strTemp) <> 95 Or Asc(strTemp) <> 35) Then
                    MsgBox "La password deve contenere almeno un carattere speciale!", vbCritical, "ORION"
                    Exit Sub
                End If
            End If
        End If
    End If
    Next
    If strNumero = "OK" And strMaiuscolo = "OK" And strMinuscolo = "OK" And strSpeciale = "OK" Then
        MsgBox "Password creata con successo ", vbInformation, "ORION"
    Else
        MsgBox "La password non rispetta i criteri", vbCritical, "ORION"
        Me.txtPassword = Null
        Me.txtPassword.SetFocus
    End If
 End Sub
 
Giuseppe

 Dim i As Integer
 
ciao
 
non ho letto il codice ma l'ho solo testato
 
se scrivo AAAaaa111$!
 
mi restituisce "La password deve contenere almeno un carattere speciale!"
 
quindi qualcosa non torna.
 
sul "consigli/miglioramenti"
se non l'hai gia previsto...non salvarla in chiaro nel db ma criptala
 
 
ciao
BFS
 

 se non l'hai gia previsto...non salvarla in chiaro nel db ma criptala 
 
ecco qui si ho bisogno di una dritta. 
Nella tabella si vede in chiaro, nella form mentre si scrive ci sono gli asterischi, ma con un'interruttore si può leggere la password inserita.
Cosa devo cercare e studiare per capire come gestire e criptare le password?
Grazie.
Giuseppe


non ricordo la fonte, ma per le mie esigenze ha sempre funzionato benone
in un modulo incolli
 
 
 
     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 CryptReleaseContext Lib "advapi32.dll" _
                                 (ByVal hProv 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, _
                                  ByRef phHash As Long) As Long
     Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
                                 (ByVal hHash 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 CryptGetHashParam Lib "advapi32.dll" _
                                 (ByVal hHash As Long, ByVal dwParam As 
Long, pbData As Any, ByRef pcbData 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 phKey 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 CryptGetProvParam Lib "advapi32.dll" _
         (ByVal hProv As Long, _
          ByVal dwParam As Long, _
          ByRef pbData As Any, _
          ByRef pdwDataLen As Long, _
          ByVal dwFlags As Long) As Long
 
 
 
Private Const SERVICE_PROVIDER As String = "Microsoft Base Cryptographic 
Provider v1.0"
Private Const KEY_CONTAINER As String = "Metallica"
Private Const PROV_RSA_FULL As Long = 1
Private Const PP_NAME As Long = 4
Private Const PP_CONTAINER As Long = 6
Private Const CRYPT_NEWKEYSET As Long = 8
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 Const NUMBER_ENCRYPT_PASSWORD As String = "´o¸sçPQ]"
 
#If VBA7 And Win64 Then
     Private hCryptProv As LongPtr
#Else
     Private hCryptProv As Long
#End If
 
Public Function EncryptionCSPConnect() As Boolean
     'Function Adapted
     'Get handle to CSP
 
     If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, 
PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then
         If CryptAcquireContext(hCryptProv, KEY_CONTAINER, 
SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then
             HandleError "Error during CryptAcquireContext for a new key 
container." & vbCrLf & _
                         "A container with this name probably already 
exists."
             EncryptionCSPConnect = False
             Exit Function
         End If
     End If
 
     EncryptionCSPConnect = True
End Function
 
Public Sub EncryptionCSPDisconnect()
     'Release provider handle.
    'Function Adapted
 
     If hCryptProv <> 0 Then
         CryptReleaseContext hCryptProv, 0
     End If
End Sub
 
Public Function EncryptData(ByVal Data As String, ByVal Password As 
String) As String
     Dim sEncrypted As String
     Dim lEncryptionCount As Long
     Dim sTempPassword As String
 
     'It is possible that the normal encryption will give you a string
     'containing cr or lf characters which make it difficult to write to 
files
     'Do a loop changing the password and keep encrypting until the 
result is ok
     'To be able to decrypt we need to also store the number of loops in 
the result
 
     'Try first encryption
     lEncryptionCount = 0
     sTempPassword = Password & lEncryptionCount
     sEncrypted = EncryptDecrypt(Data, sTempPassword, True)
 
     'Loop if this contained a bad character
     Do While (InStr(1, sEncrypted, vbCr) > 0) _
           Or (InStr(1, sEncrypted, vbLf) > 0) _
           Or (InStr(1, sEncrypted, Chr$(0)) > 0) _
           Or (InStr(1, sEncrypted, vbTab) > 0)
 
         'Try the next password
         lEncryptionCount = lEncryptionCount + 1
         sTempPassword = Password & lEncryptionCount
         sEncrypted = EncryptDecrypt(Data, sTempPassword, True)
 
         'Don't go on for ever, 1 billion attempts should be plenty
         If lEncryptionCount = 99999999 Then
             Err.Raise vbObjectError + 999, "EncryptData", "This data 
cannot be successfully encrypted"
             EncryptData = ""
             Exit Function
         End If
     Loop
 
     'Build encrypted string, starting with number of encryption iterations
     EncryptData = EncryptNumber(lEncryptionCount) & sEncrypted
End Function
 
Public Function DecryptData(ByVal Data As String, ByVal Password As 
String) As String
     Dim lEncryptionCount As Long
     Dim sDecrypted As String
     Dim sTempPassword As String
 
     'When encrypting we may have gone through a number of iterations
     'How many did we go through?
     lEncryptionCount = DecryptNumber(Mid$(Data, 1, 8))
 
     'start with the last password and work back
     sTempPassword = Password & lEncryptionCount
     sDecrypted = EncryptDecrypt(Mid$(Data, 9), sTempPassword, False)
 
     DecryptData = sDecrypted
End Function
 
Public Function GetCSPDetails() As String
     Dim lLength As Long
     Dim yContainer() As Byte
 
     If hCryptProv = 0 Then
         GetCSPDetails = "Not connected to CSP"
         Exit Function
     End If
 
     'For developer info, show what the CSP & container name is
     lLength = 1000
     ReDim yContainer(lLength)
     If CryptGetProvParam(hCryptProv, PP_NAME, yContainer(0), lLength, 
0) <> 0 Then
         GetCSPDetails = "Cryptographic Service Provider name: " & 
ByteToStr(yContainer, lLength)
     End If
     lLength = 1000
     ReDim yContainer(lLength)
     If CryptGetProvParam(hCryptProv, PP_CONTAINER, yContainer(0), 
lLength, 0) <> 0 Then
         GetCSPDetails = GetCSPDetails & vbCrLf & "Key Container name: " 
& ByteToStr(yContainer, lLength)
     End If
End Function
 
Private Function EncryptDecrypt(ByVal Data As String, ByVal Password As 
String, ByVal encrypt As Boolean) As String
 
     #If Win64 Then
        Dim hHash As LongPtr
        Dim hKey  As LongPtr
        Dim hHashNull As LongPtr
        Dim hKeyNull As LongPtr
 
        hHashNull = 0&
        hKeyNull = 0&
 
     #Else
        Dim hHash As Long
         Dim hKey As Long
         Dim hHashNull As Long
        Dim hKeyNull As Long
     #End If
 
 
     Dim lLength As Long
     Dim sTemp As String
     Dim GetValue As Boolean
 
     If hCryptProv = 0 Then
         HandleError "Not connected to CSP"
         Exit Function
     End If
 
     '--------------------------------------------------------------------
     'The data will be encrypted with a session key derived from the
     'password.
     'The session key will be recreated when the data is decrypted
     'only if the password used to create the key is available.
     '--------------------------------------------------------------------
 
     'Create a hash object.
     GetValue = CryptCreateHash(hCryptProv, CALG_MD5, hKeyNull, 0, hHash)
 
     If GetValue = False Then
         HandleError "Error during CryptCreateHash!"
     End If
 
     'Hash the password.
     If CryptHashData(hHash, Password, Len(Password), 0) = 0 Then
         HandleError "Error during CryptHashData."
     End If
 
     'Derive a session key from the hash object.
     If CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 
0 Then
         HandleError "Error during CryptDeriveKey!"
     End If
 
     'Do the work
     sTemp = Data
     lLength = Len(Data)
     If encrypt Then
         'Encrypt data.
         If CryptEncrypt(hKey, hHashNull, True, 0, sTemp, lLength, 
lLength) = 0 Then
             HandleError "Error during CryptEncrypt."
         End If
     Else
         'Encrypt data.
         GetValue = CryptDecrypt(hKey, hHashNull, True, 0, sTemp, lLength)
         If GetValue = 0 Then
             HandleError "Error during CryptDecrypt."
         End If
     End If
 
     'This is what we return.
     EncryptDecrypt = Mid$(sTemp, 1, lLength)
 
     'Destroy session key.
     If hKey <> 0 Then
         CryptDestroyKey hKey
     End If
 
     'Destroy hash object.
     If hHash <> 0 Then
         CryptDestroyHash hHash
     End If
End Function
 
Private Sub HandleError(ByVal error As String)
     'You could write the error to the screen or to a file
     MsgBox error, vbCritical, "errore"
End Sub
 
Private Function ByteToStr(ByRef ByteArray() As Byte, ByVal lLength As 
Long) As String
     Dim i As Long
     For i = LBound(ByteArray) To (LBound(ByteArray) + lLength)
         ByteToStr = ByteToStr & Chr$(ByteArray(i))
     Next i
End Function
 
Private Function EncryptNumber(ByVal lNumber As Long) As String
     Dim i As Long
     Dim sNumber As String
 
     sNumber = Format$(lNumber, "00000000")
 
     For i = 1 To 8
         EncryptNumber = EncryptNumber & 
Chr$(Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)) + Val(Mid$(sNumber, i, 1)))
     Next i
End Function
 
Private Function DecryptNumber(ByVal sNumber As String) As Long
     Dim i As Long
 
     For i = 1 To 8
         DecryptNumber = (10 * DecryptNumber) + (Asc(Mid$(sNumber, i, 
1)) - Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)))
     Next i
End Function
 
 
--------------------------------------------
 
 
per criptare qualcosa
 
EncryptionCSPConnect
StringaCriptata= EncryptData(StringaNONcriptata, "QuiMettiLaChiave")
EncryptionCSPDisconnect
 
 
per decriptare
 
EncryptionCSPConnect
StringaNONcriptata = DecryptData(StringaCriptata, "QuiMettiLaChiave")
EncryptionCSPDisconnect
 
 
"QuiMettiLaChiave" è la stinga che inventi per codificare i dati
 
per le mie esigenze non ho mai dovuto cercare qualcosa di più "solido"
 
 
ciao
BFS
 
 


Grazie Fabio.
Provo a mettere in pratica.
Il codice quindi bisogna copiarlo e avviarlo sia nel backend che nel frontend, giusto?
Giuseppe


solo nel front
BFS