Ciao redbluewolves,
la routine che chiedi è un po’ lunghetta; comunque dato che ho un po’ di tempo disponibile l’ho scritta.
In una Frm chiamata frmLogin inserisci due Txt dal Nome: TxtApriUN e TxtApriPW e due CmdButton dal Nome: cmdOK e cmdCancel. Nel progetto di prova inserisci anche una Form dal Nome FrmProva, che ti servirà per provare l’apertura del programma.
Nel modulo della frmLogin inserisci:
codice:
Option Explicit
' Annulla Esce dall'applicazione:
Public OK As Boolean
Private Sub Form_Load()
With frmLogin
.WindowState = vbNormal
.Top = 3045
.Height = 2475
.Width = 4920
End With
End Sub
' E' stato premuto Annulla:
Private Sub cmdCancel_Click()
OK = False
Me.Hide
End Sub
'Verifica la validità della password e dell'UserName:
Private Sub cmdOK_Click()
On Error GoTo ErrHandler
Dim ConSR As New ADODB.Connection
Dim RSTctr As New ADODB.Recordset
Dim sPassWord As String
Dim sVpassW As String
Dim sVUName As String
Dim vRegNomeComp As Variant
Dim vRegNomeUser As Variant
Dim user As Boolean
user = False
'Acquisisce il Nome dell'Utente-Funzione nel Modulo:
Dim sBuffer As String
Dim lSize As Long
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetUserName(sBuffer, lSize)
If lSize > 0 And Len(TxtApriUN.Text) = 0 Then
TxtApriUN.Text = Left$(sBuffer, lSize)
ElseIf lSize = 0 And Len(TxtApriUN.Text) = 0 Then
TxtApriUN.Text = "admin"
End If
' Acquisisce la pw e username digitati:
sPassWord = TxtApriPW.Text
sUName = TxtApriUN.Text
'Esegue la connessione con il DataBase:
With ConSR
.ConnectionString = DataConnessione
.CursorLocation = adUseClient 'tipo di cursore
.Mode = adModeShareDenyNone 'nessuna limitazione
.CommandTimeout = 15
.Open
End With
' Controlla se la PassWord è presente nel DB:
RSTctr.Source = "SELECT UsernameX, PasswordX FROM TblPW WHERE UsernameX ='" & sUName & "' And PasswordX='" & sPassWord & "'"
RSTctr.Open , ConSR
Do Until (RSTctr.EOF)
If sUName = RSTctr("UsernameX") And sPassWord = RSTctr("PasswordX") Then
vRegNomeComp = StrComp(RSTctr("PasswordX"), sPassWord, vbTextCompare)
vRegNomeUser = StrComp(RSTctr("UsernameX"), sUName, vbTextCompare)
' La PW è uguale Apre il file:
If vRegNomeComp = 0 And vRegNomeUser = 0 Then
sngNuV = 0
Me.Hide
OK = True
user = True
End If
Exit Do
Else
user = False
End If
RSTctr.MoveNext
Loop
'La password o il nome utente sono errati:
If user = False Then
sngNuV = 1 + sngNuV
MsgBox "La PassWord o il Nome utente non è corretto! Riprovare." & Chr(13) _
& "Prove effettuate " & sngNuV & " di 4." & Chr(13) _
& "Attenzione, alla 4^ prova il programma verrà chiuso!", vbCritical, "Prova PW"
TxtApriPW.SetFocus
TxtApriPW.SelStart = 0
TxtApriPW.SelLength = Len(TxtApriPW.Text)
If sngNuV > 3 Then
MsgBox "E' stata introdotta per quattro volte una PassWord non è corretta !" & Chr(13) _
& "Il programma verrà chiuso.", vbCritical, "Prova PW"
Unload frmLogin
Set frmLogin = Nothing
End
End If
End If
'Chiude e cancella il recordSet:
If GetState(RSTctr.State) = "adStateOpen" Then
RSTctr.Close
Set RSTctr = Nothing
End If
'Chiude la connessione - TblPW:
If GetState(ConSR.State) = "adStateOpen" Then
ConSR.Close
Set ConSR = Nothing
End If
ErrHandler:
If Err.Number <> 0 Then
MsgBox "Errore: " & Err.Number & " " & Err.Description & Chr(13) _
& "Errore nella ricerca della password o del Nome utente." & Chr(13) _
& "Inserire una Password/Nome utente corretti.", vbCritical, "Prova PW"
Err.Clear
'Chiude e cancella il recordSet:
If GetState(RSTctr.State) = "adStateOpen" Then
RSTctr.Close
Set RSTctr = Nothing
End If
'Verifica e Chiude la connessione - TblPW:
If GetState(ConSR.State) = "adStateOpen" Then
ConSR.Close
Set ConSR = Nothing
End If
Exit Sub
End If
End Sub
'Verifica lo stato della connessione:
Public Function GetState(intState As Integer) As String
Select Case intState
Case adStateClosed
GetState = "adStateClosed"
Case adStateOpen
GetState = "adStateOpen"
End Select
End Function
In un modulo .bas inserisci:
codice:
Public DataConnessione As String
' Acquisisce il Nome dell'Utente:
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpbuffer As String, nSize As Long) As Long
' Acquisisce l'UserName all'apertura del file:
Public sUName As String
' Conta quante volte la pw è errata:
Public sngNuV As Single
' Sub d'avvio del programma:
Sub Main()
Call DataConnessione2
frmLogin.Show vbModal
If Not frmLogin.OK Then
'L'accesso non è riuscito, esce dall'applicazione:
End
End If
' Chiude la frmLogin:
Unload frmLogin
Set frmLogin = Nothing
' Apre la 1^ Frm del programma:
FrmProva.Show
End Sub
' Connessione con il DB:
Public Sub DataConnessione2()
On Error GoTo ErrHandler
' Stringa di connessione Con password:
DataConnessione = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ProvaPW.mdb;Persist Security Info=False;Jet OLEDB:Database Password=LMONDI;"
ErrHandler:
If Err.Number <> 0 Then
MsgBox "Errore: " & Err.Number & " " & Err.Description & Chr(13) _
& "Errore nella connessione al Data Base." & Chr(13) _
& "Riavviare il programma.", vbCritical, "Prova PW"
Err.Clear
Exit Sub
End If
End Sub
La routine è funzionante, dato che l'ho provata e certamente può essere migliorata.
PS. il DataBase utilizzato nell'esempio è ACCESS.
Permessi di invio
