Sub Init_Login()
Dim Cnn As New ADODB.Connection
Dim Cmd As New ADODB.Command
Dim Rst_Temp As New ADODB.Recordset
Dim Rst_LOCAL As New ADODB.Recordset
Dim StrCn As String
Dim Current_file As String
Dim sSQL As String
' Controle si ODBC enregistré et enregistre le cas echeant...
CONTROLE_ODBC_1 ' Fonction Externe d'un enregistrement ODBC Dans la Base de Registre
CONTROLE_ODBC_2
Current_file = Application.Path & '\\' & 'LOGINS.XML' ' Nom du fichier et chemin
If Init_Data_Files('LOGINS.XML', 120) = True Then ' Test le temps d'existence du fichier
' Si sup à 120 mn ou existe pas, Il faut réinterroger la base :
StrCn = 'Provider=MSDASQL.1;Persist Security Info=False;Data Source=TEST_FT;UID=Admin;PWD=dede'
Cnn.Open StrCn ' Connection à la base Access
With Rst_Temp ' Preparation de la requete SQL
.CursorLocation = adUseClient
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
End With
' Requête SQL
sSQL = 'SELECT BASE_LOG.LOG' & _
' FROM BASE_LOG' & _
' WHERE (((BASE_LOG.FLAG_USE_ETAT)=False)' & _
' AND ((BASE_LOG.FONCTION)='F3')) ' & _
' OR (((BASE_LOG.FLAG_USE_ETAT)=True)' & _
' AND ((BASE_LOG.FONCTION) In ('F3',F2','ADM')))' & _
' ORDER BY BASE_LOG.FONCTION, BASE_LOG.LOGIN;'
With Rst_Temp
.Open sSQL, Cnn, adOpenForwardOnly, adLockOptimistic, adCmdText ' Ouvre la base et traite la requête
.Save Current_file, adPersistXML ' Crée le fichier XML
.Close ' Ferme la base
End With
Cnn.Close
Rst_LOCAL.Open Current_file ' ouvre le XML
Else
Rst_LOCAL.Open Current_file
End If
With Rst_LOCAL ' Ajout dans la combobox des logins
.MoveFirst ' depuis le fichier XML
Do While Not .EOF
If !LOGIN <> 'ADMIN' Then
Frm_login.cmbx_login.AddItem !LOGIN
.MoveNext
Else
.MoveNext
End If
Loop
End With
Set Rst_Temp = Nothing
Frm_login.Show ' Affiche la Userform
End Sub
'----------------------------
' Fonction qui test si le fichier existe si oui si heure de creaton > 120 mn
Public Function Init_Data_Files(ByVal FilePath As String, ByVal NbMinutesValidite As Integer) As Boolean
Dim Current_file As String
Current_file = Application.Path & '\\' & FilePath
If Dir(Current_file) <> '' Then 'µSi le fichier existe
If DateDiff('n', FileDateTime(Current_file), Now()) < NbMinutesValidite Then
' Rien à faire car heure de creation du fichier > 120 mn
' Nothing to do the file is up to date
Init_Data_Files = False
Else
Kill Current_file ' Sinon efface le fichier
Init_Data_Files = True
End If
Else
' Query the DATABASE
Init_Data_Files = True ' Passe le parametre à True pour que
' de retour à ma procedure on sache si il faut ou pas interroger la base
