Private Sub Form_Timer()
On Error GoTo Err_LogOffChk
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

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

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

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

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

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 PASWD =\'"& 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

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

Dim Utilisateur As DAO.User, MonGroup As DAO.Group

Set Utilisateur = DBEngine.Workspaces(0).Users(DBEngine.Workspaces(0).UserName)
For Each MonGroup In Utilisateur.Groups
    If MonGroup.Name = "Admins" Then
        MsgBox Utilisateur.Name & " est dans le groupe " & MonGroup.Name
        Exit For
    End If
Next

Dim Valeur As Variant
Valeur = SysCmd(acSysCmdAccessVer)

Const JET_SCHEMA_USERROSTER = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"

Sub WriteUserConnected()
 'To determine who is logged onto a database
   Dim cn As New ADODB.Connection
   Dim rs As New ADODB.Recordset
   Dim i, j As Long
   Dim rsUC As DAO.Recordset
   
   Set rsUC = db.OpenRecordset("T_USER_CONNECTED", dbOpenDynaset)
   Set cn = CurrentProject.Connection
   
   ' The user roster is exposed as a provider-specific schema rowset
   ' in the Jet 4.0 OLE DB provider.  You have to use a GUID to
   ' reference the schema, as provider-specific schemas are not
   ' listed in ADO's type library for schema rowsets
   
   Set rs = cn.OpenSchema(adSchemaProviderSpecific, , JET_SCHEMA_USERROSTER)
   
   'Output the list of all users in the current database.
   db.Execute "DELETE * FROM T_USER_CONNECTED"
   While Not rs.EOF
      With rsUC
      .AddNew
      !COMPUTER_NAME = rs.Fields(0)
      !LOGIN_NAME = rs.Fields(1)
      !CONNECTED = rs.Fields(2)
      !SUSPECTED_STATE = rs.Fields(3)
      .Update
      End With
      rs.MoveNext
   Wend
   
End Sub

"C:\Program Files\Microsoft Office\Office\MSACCESS.EXE" "d:\bd1.mdb" /decompile

REGEDIT4

[HKEY_CLASSES_ROOT\Access.Application.9\shell]

[HKEY_CLASSES_ROOT\Access.Application.9\shell\Compacter]
"EditFlags"=hex:01,00,00,00
@="&Compacter"

[HKEY_CLASSES_ROOT\Access.Application.9\shell\Compacter\command]
@="\"C:\\Program Files\\Microsoft Office\\Office\\MSACCESS.EXE\" \"%1\" /COMPACT "

[HKEY_CLASSES_ROOT\Access.Application.9\shell\Décompiler]
"EditFlags"=hex:01,00,00,00
@="&Décompiler"

[HKEY_CLASSES_ROOT\Access.Application.9\shell\Décompiler\command]
@="\"C:\\Program Files\\Microsoft Office\\Office\\MSACCESS.EXE\" \"%1\" /DECOMPILE "

Sub ChangeMotPass()
On Error GoTo err
Dim odb As DAO.Database
Set odb = CurrentDb
odb.NewPassword "ancien", "nouveau"
MsgBox "Mot de passe changé"
 
fin:
Set odb = Nothing
Exit Sub
 
err:
Select Case err.Number
    Case 3031
        MsgBox "Mot de passe non valide", vbCritical, "Sécurité"
    Case Else
        MsgBox "Une erreur est survenue pendant le changement du mot de passe", _
            vbCritical, "Erreur"
End Select
Resume fin
End Sub

Sub SetProperty(strName As String, intType As Variant, vValue As Variant)

    Dim prpNew As DAO.Property
    Dim db As DAO.Database

    Set db = CurrentDb()

    ' Tente de définir la propriété spécifiée.
    On Error GoTo Err_SetProperty

    db.Properties(strName) = vValue
    
Exit_SetProperty:
    db.Close
    Set db = Nothing

    Exit Sub

Err_SetProperty:

    ' L'erreur 3270 signifie que la propriété est
    ' introuvable.
    Select Case Err.Number
        Case 3270
            ' Crée une propriété, définit sa valeur et
            ' l'ajoute à la collection Properties.
            Set prpNew = db.CreateProperty(strName, intType, vValue)
            db.Properties.Append prpNew
        
        Case Else
            MsgBox "erreur n°" & Err.Number & vbCrLf & Err.Description
    
    End Select
    GoTo Exit_SetProperty
    
End Sub

setproperty "NouvellePropriete", dbboolean, false

setproperty "RepTravail", dbtext, "C:\Program Files\Office\"

Dim strPath as String strPath = CurrentDB.Properties("RepTravail")