Private Sub connexion_Click()
Me.Requery
Dim sql, User_id, User_groupe   As String
Dim rs As DAO.Recordset
Static i As Byte
sql = "SELECT * FROM T_USERS WHERE TRIGRAMME = '" & Me.txt_user & "' AND PASSWD =''"& Me.txt_pass & "';"
Set rs = CurrentDb.OpenRecordset(sql)
If Not rs.EOF Then
  DoCmd.OpenForm "F_Autre_Formulaire", acNormal, , , , acWindowNormal
  DoCmd.close acForm, "F_CONNEXION"
  User_id = rs("TRIGRAMME").value
  User_groupe = rs("GROUPE").value
Else
  MsgBox "(Identifiant, Mot de Passe) incorrect ", vbInformation, "Connexion"
  i = i + 1
End If
If i = 3 Then 
Msgbox "Vous avez dépassé le nombre de tentatives autorisés", vbCritical
DoCmd.Quit
End If
End Sub

' -- Evenement sur ouverture du formulaire
Private Sub Form_Open(Cancel As Integer)
If TestDDELink(Application.CurrentDb.Name) Then
   MsgBox "Cette base est déja ouverte sur votre poste", VbInformation
   DoCmd.Quit
End If
End Sub

Function TestDDELink(ByVal strNomApplication As String) As Integer
Dim varCanalDDE As Long
On Error Resume Next
Application.SetOption "Ignore DDE Requests", True
' -- Ouvrir un canal entre instance de la base
varCanalDDE = DDEInitiate("MSAccess", strNomApplication)
' -- Si la base n'est pas ouverte, pas de canal de communication entre deux instances
If Err Then
  TestDDELink = 0
Else
  TestDDELink = 1
  DDETerminate varCanalDDE 
  DDETerminateAll                    
End If
Application.SetOption ("Ignore DDE Requests"), False
End Function

Sub SetBypassProperty()
Const DB_Boolean As Long = 1
    ChangeProperty "AllowBypassKey", DB_Boolean, False
End Sub
Sub UnSetBypassProperty()
Const DB_Boolean As Long = 1
    ChangeProperty "AllowBypassKey", DB_Boolean, True
End Sub

Function ChangeProperty(strPropName As String, varPropType As Long varPropValue As Variant) As Integer
    Dim dbs As Database
    prp As Variant
    Const conPropNotFoundError = 3270
    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
Change_Bye:
    Exit Function
Change_Err:
    If Err = conPropNotFoundError Then    ' Propriété non trouvée.
    Set prp = dbs.CreateProperty(strPropName, _
    varPropType, varPropValue)
    dbs.Properties.Append prp
    Resume Next
Else
  ' --Erreur inconnue.
  Resume Change_Bye
End If
End Function

Function Ouvrir_Base_Exclusif()
Dim Bd As Database
On Error Resume Next
Set Bd = DbEngine (0).OpenDatabase("C:\Ma_base.mdb", True)
If Err.Number<> 0 Then
Msgbox Err.Number & " Impossible d'ouvrir la base en mode Exclusif " & vbcrlf & Err.Description, VbInformation 
Else
MsgBox "La base de données est ouverte en mode exclusif.", VbInformation
End If
End Function

Function Ouvrir_Table_Exclusif (Bd As Database, Ma_Table As String) As Integer
Dim rcd As DAO.Recordset
On Error GoTo Erreur
Set rcd = Bd.OpenRecordset(Ma_Table, dbOpenTable, dbDenyRead) 
' -- Mes traitemens en mode exclusif
Rcd.Close
Set rcd = Nothing
Exit Function
Erreur:
Msgbox Err.Number & vbcrlf & Err.Description
End Function

SELECT Name, ForeignName, Database 
FROM MSysObjects 
WHERE MSysObjects.Type=6;

Public Function DateExpirationApplication()
If Date >= DateSerial(2003, 12, 31) Then
MsgBox "La date d'expiration de l'application est dépassée", vbExclamation
DoCmd.Quit
End If
End Function

Private Sub Form_Timer()
On Error GoTo Err_LogOff
Dim Lancer As Boolean
Dim rcd As DAO.Recordset
Set rcd = CurrentDb.OpenRecordset("Administration")
rcd.MoveFirst
Lancer = rcd.Fields(0)
rstLO.Close
CurrentDb.Close
' --Si la case est cochée
If Lancer Then Application.Quit acQuitSaveAll
Exit_LogOff:
   Exit Sub
Err_LogOffChk:
   MsgBox Err.Number & vbCrLf & Err.Description, vbInformation, "Erreur"
   Resume Exit_LogOff
End Sub

Private Type Un_Connecté
' --nom PC
PC(1 To 32) As Byte
' --nom utilisateur
User(1 To 32) As Byte
End Type

Public Function WHO_IS() As String
' -- retourne une liste séparée par des points virgules indiquant le nom de l'ordinateur ainsi que
' -- l'utilisateur connecté à la base.
On Error GoTo Err_WHO_IS
Dim Mon_LDB As Integer, i As Integer
Dim Mon_Chemin As String
Dim Mon_Log As String, Ma_Connexion As String
Dim Nom_PC As String, Nom_Utilisateur As String
Dim utilisateur As Un_Connecté
Mon_Chemin = CurrentDb.Name
CurrentDb.Close
' --Aller chercher le LDB
Mon_Chemin = Left(Mon_Chemin, InStr(1, Mon_Chemin, ".")) + "LDB"
Mon_LDB = FreeFile
' --Ouvrir le LDB
Open Mon_Chemin For Binary Access Read Shared As Mon_LDB
' -- Lire le LDB
Do While Not EOF(Mon_LDB)
   ' -- Chaque enregistrement lu est placé dans la variable utilisateur pour y être traité.
   Get Mon_LDB, , utilisateur
   With utilisateur
      i = 1
      Nom_PC = ""
   ' -- nom du PC
  While .PC(i) <> 0
         Nom_PC = Nom_PC & Chr(.PC(i))
         i = i + 1
    Wend
      i = 1
      Nom_Utilisateur = ""
  ' -- nom de l'utilisateur
  While .User(i) <> 0
         Nom_Utilisateur = Nom_Utilisateur & Chr(.User(i))
         i = i + 1
    Wend
   End With
   Mon_Log = Nom_PC & " | " & Nom_Utilisateur
   If InStr(Ma_Connexion, Mon_Log) = 0 Then
      Ma_Connexion = Ma_Connexion & Mon_Log & ";"
   End If
Loop
Close Mon_LDB
' --WHO_IS contient la liste des utilisateurs
WHO_IS = Ma_Connexion
Exit_WHO_IS:
   Exit Function
Err_WHO_IS:
      MsgBox Err.Number & vbCrLf & Err.Description, vbInformation, "Erreur"
      Close Mon_LDB
      Resume Exit_WHO_IS
End Function