sStatusBarText

Sub sStatusBarText()
 
Dim obj As AccessObject
Dim frm As Form
Dim ctl As Control
Dim prp As Property
 
 
For Each obj In Application.CurrentProject.AllForms
    'Demande confirmation pour le formulaire en question
  Select Case MsgBox(Formulaire : " & obj.Name, vbQuestion + vbYesNoCancel)
    'si OUI
    Case vbYes
      'Ouvre le formulaire en mode création
      DoCmd.OpenForm obj.Name, acDesign
      Set frm = Forms(obj.Name)
       'Applique le propriété à chaque controle
      For Each ctl In frm.Controls
        For Each prp In ctl.Properties
          If prp.Name = "StatusBarText" Then
            prp = InputBox(ctl.Name & " :", frm.Name & " - StatusBarText", _
                   IIf(prp = "",  ctl.Name, prp))
            Exit For
          End If
        Next prp
      Next ctl
      'Enregistre et ferme le formulaire
      DoCmd.Close acForm, obj.Name, acSaveYes
     'Si annuler alors, quitter le traitement
    Case vbCancel
      Exit Sub
  End Select
Next obj
set variable = nothing
End Sub

Private Sub Commande1_Click()
'Gestion d'erreur
On Error Resume Next
'Declaration des variables
Dim Pere As String
Dim T As DAO.TableDef
Dim F As DAO.Field
Dim P As DAO.Property
Dim DB As DAO.Database
'Vide le treeview
TreeView0.Nodes.Clear
'Liste les tables
For Each T In DB.TableDefs
    'Verifie si c'est une table système
    If T.Attributes = 0 Or (T.Attributes <> 0 And Me.chk_systeme) Then
    TreeView0.Nodes.Add , , T.Name, T.Name
    'Liste les champs
    For Each F In T.Fields
        Pere = T.Name
        TreeView0.Nodes.Add Pere, tvwChild, Pere & "#" & _
             F.Name, F.Name
        Pere = Pere & "#" & F.Name
        'Liste les propriétés
        For Each P In F.Properties
        TreeView0.Nodes.Add Pere, tvwChild, Pere & F.Name & _
            "#" & P.Name, P.Name & " : " & LireProperty(F, P.Name)
        Next P
    Next F
    End If
Next T
End Sub
  'Cette fonction renvoit le type d'un champ en français 
  'en fonction de son type en numérique
Private Function Renvoi_Type(ByVal n As Integer) As String
        Dim s As String
        Select Case n
            Case dbBoolean
                s = "Oui/Non"
            Case dbByte
                s = "Octet"
            Case dbInteger
                s = "Entier"
            Case dbLong
                s = "Entier long"
            Case dbCurrency
                s = "Monétaire"
            Case dbSingle
                s = "Réel S"
            Case dbDouble
                s = "Réel D"
            Case dbDate
                s = "Date"
            Case dbBinary
                s = "Binaire"
            Case dbText, dbChar
                s = "Texte"
            Case dbLongBinary, dbVarBinary
                s = "Binaire 2"
            Case dbMemo
                s = "Mémo"
            Case dbGUID
                s = "GUID"
            Case dbBigInt
                s = "Numérique HP"
            Case dbNumeric
                s = "Numérique"
            Case dbDecimal
                s = "Décimal"
            Case dbFloat
                s = "Flottant"
            Case dbTime, dbTimeStamp
                s = "Heure"
        End Select
        Renvoi_Type = s
    End Function
 
'Cette fonction permet de lire une propriété
'Et de gerer les erreurs de lecture.
 
Private Function LireProperty(Objet As Object, _
      Propriete As String) As String
 
'Gere les erreurs
On Error GoTo err
'Si l'objet est un champ et que la propriété est type
'alors convertit la valeur en français
If TypeOf Objet Is DAO.Field And Propriete = "Type" Then
    LireProperty = Renvoi_Type(Objet.Properties(Propriete))
Else
    LireProperty = Objet.Properties(Propriete)
End If
err:
End Function
 
Private Sub Commande12_Click()
DoCmd.Close
End Sub
 
Private Sub Form_Load()
Me.chk_systeme = True
End Sub

Function fnctGetFieldDescription(ByVal WhatTable As String, _
  ByVal WhatField As String, Optional ByVal PropertyName As _
  String ="Description", Optional ByVal CreateIt As Boolean = False) 
Dim oDB As DAO.Database 
Dim oTBL As DAO.TableDef 
Dim oField As DAO.Field 
Dim oPRP As DAO.Property 
Dim strDescription As String 
 
  On Error GoTo L_Err_FieldDescription 
  strDescription = vbNullString 
 
  Set oDB = CurrentDb 
  Set oTBL = oDB.TableDefs(WhatTable) 
  Set oField = oTBL.Fields(WhatField) 
  strDescription = oField.Properties(PropertyName) 
 
L_Ex_FieldDescription: 
  Set oDB = Nothing 
  Set oTBL = Nothing 
  Set oPRP = Nothing 
  Set oField = Nothing 
  fnctGetFieldDescription = strDescription 
  Exit Function 
 
L_Err_FieldDescription: 
  If Err = 3270 Then 
    If CreateIt Then 
      Set oPRP = oField.CreateProperty(PropertyName, dbText, _
   "Nouvelle description") 
      oField.Properties.Append oPRP 
      MsgBox "La propriété '" & PropertyName & "' a été ajoutée au champ " & _
   WhatField & "...", 48, "Propriété ajoutée à la collection" 
    End If 
  Else 
    MsgBox "Impossible d'avoir des information sur le champ '" & WhatField & _
   "' !" & vbCrLf & Err.Description, 48, "Erreur" 
  End If 
  Resume L_Ex_FieldDescription 
End Function

Sub ObtenirDescription() 
Dim strMaTable As String 
Dim strMonChamp As String 
Dim strMaPropriete As String 
  strMaTable = "TBLClients" 
  strMonChamp = "ProvenanceContact" 
  strMaPropriete = "Description" 
 
  Debug.Print fnctGetFieldDescription(strMaTable, strMonChamp, strMaPropriete) 
End Sub

'Fonction qui teste l'existence d'une table
Private Function TableExiste(strNom As String, _
        oDb As DAO.Database) As Boolean
'Gestion d'erreur : En cas d'erreur, aller à l'étiquette
'err (càd retouner Faux)
On Error GoTo err
 
  Dim oTbl As DAO.TableDef
  'Tente d'accéder à la table
  Set oTbl = oDb.TableDefs(strNom)
  'Retourne Vrai
  TableExiste = True
  Set oTbl = Nothing
err:
End Function

'Fonction qui retourne le type du champ en français
Private Function TypeFr(intType As Integer) As String
Select Case intType
  Case dbText, dbMemo: TypeFr = "Texte"
  Case dbBoolean: TypeFr = "Booléen"
  Case dbDate, dbTime, dbTimeStamp: TypeFr = "Date"
  Case Else: TypeFr = "Numérique"
End Select
End Function

'Fonction qui rend les chaînes de caractères valides dans les requêtes
Private Function MAJTexte(strChaine As String) As String
MAJTexte = Chr(34) & Replace(strChaine, Chr(34), Chr(34), , _
  , vbTextCompare) & Chr(34)
End Function

'Procédure qui crée la table du dictionnaire
Private Sub CreerTableDico(oDb As DAO.Database)
Dim oTbl As DAO.TableDef
Dim oFld As DAO.Field
'Si la table n'existe pas alors
If Not TableExiste(NOMTABLEDICO, oDb) Then
  'Crée la table
  Set oTbl = oDb.CreateTableDef(NOMTABLEDICO)
  'Ajoute les champs
  With oTbl
    .Fields.Append .CreateField(NOMCHAMPTABLE, dbText, 255)
    .Fields.Append .CreateField(NOMCHAMPATTRIBUT, dbText, 255)
    .Fields.Append .CreateField(NOMCHAMPTYPE, dbText, 15)
    Set oFld = .CreateField(NOMCHAMPRG, dbText, 255)
    'Autorise les chaines vide pour les règles de gestion
    oFld.AllowZeroLength = True
    .Fields.Append oFld
  End With
  'Ajoute la table à la base de données
  oDb.TableDefs.Append oTbl
Else
'Sinon vide la table
oDb.Execute "DELETE FROM " & NOMTABLEDICO
End If
End Sub

'Procédure principale
Public Sub EnrichirDico()
Dim oDb As DAO.Database
Dim oTbl As DAO.TableDef
Dim oFld As DAO.Field
Set oDb = CurrentDb
'Lance la création de la table dico si besoin
CreerTableDico oDb
'Explore chaque table
For Each oTbl In oDb.TableDefs
  'Si la table n'est pas système et différente de la table dico
  If (oTbl.Attributes And dbSystemObject) = 0 And oTbl.Name <> NOMTABLEDICO Then
    'Alors explore chaque champ
    For Each oFld In oTbl.Fields
      'Enrichit la table du dictionnaire
      oDb.Execute "INSERT INTO " & NOMTABLEDICO & " VALUES (" & _
            MAJTexte(oTbl.Name) & "," & _
            MAJTexte(oFld.Name) & "," & _
            MAJTexte(TypeFr(oFld.Type)) & "," & _
            MAJTexte(oFld.ValidationRule) & ")"
    Next oFld
  End If
Next oTbl
 
'libère les objets
Set oFld = Nothing
Set oTbl = Nothing
Set oDb = Nothing
 
End Sub

'------------------------------
'Recherche la chaîne valueToFind dans les requêtes 
'stockées de la base courante 
'Retourne une collection d'objet querydef trouvés. 
'------------------------------
'Parametres : 
'   valueToFind : chaine à rechercher dans les requêtes 
'   QueryFilterName : s'il est fixé, le nom de requête 
'doit contenir cette chaîne pour être pris en compte 
'------------------------------
Public Function searchInQueryDefs(ByVal valueToFind As String, _
 Optional ByVal QueryFilterName As String) As Collection 
Dim qryCurrent As DAO.QueryDef 
Dim Db as DAO.Database
Dim colQueries As New Collection 
 
  On Error GoTo ErreursearchInQueryDefs 
 
  'Instancie un objet Database correspondant à la base courante
  Set Db=CurrentDb
  'Pour chaque requête de la base, recherche la chaine
  For Each qryCurrent In Db.QueryDefs 
      If QueryFilterName = "" Or _
  (InStr(qryCurrent.Name, QueryFilterName) > 0) Then 
          If Nz(InStr(qryCurrent.SQL, valueToFind), 0) > 0 Then 
              colQueries.Add qryCurrent 
          End If 
      End If 
  Next 
 
  Set searchInQueryDefs = colQueries 
 
FinsearchInQueryDefs: 
    Exit Function 
ErreursearchInQueryDefs: 
    MsgBox Err.Number & Err.Description, vbExclamation, _
Application.CurrentProject.Name 
    Resume FinsearchInQueryDefs 
End Function

Sub TesterExemple() 
Dim qryCurrent As QueryDef 
 
  For Each qryCurrent In searchInQueryDefs("Clients", "Factures") 
      Debug.Print qryCurrent.Name 
      Debug.Print qryCurrent.SQL 
  Next 
End Sub

Factures 
 
SELECT DISTINCTROW [Commandes].[Destinataire], [Commandes].[Adresse livraison], 
[Commandes].[Ville livraison], [Commandes].[Région livraison], 
[Commandes].[Code postal livraison], [Commandes].[Pays livraison], 
[Commandes].[Code client], [Clients].[Société], [Clients].[Adresse], 
[Clients].[Ville], [Clients].[Région], [Clients].[Code postal], 
[Clients].[Pays], [Prénom] & " " & [Nom] AS Vendeur, [Commandes].[N° commande], 
[Commandes].[Date commande], [Commandes].[À livrer avant], 
[Commandes].[Date envoi], [Messagers].[Nom du messager], 
[Détails commandes].[Réf produit], [Produits].[Nom du produit], 
[Détails commandes].[Prix unitaire], [Détails commandes].[Quantité], 
FROM Produits INNER JOIN (Messagers INNER JOIN (Employés 
INNER JOIN ((Clients INNER JOIN Commandes ON 
[Clients].[Code client]=[Commandes].[Code client]) INNER JOIN 
[Détails commandes] ON 
[Commandes].[N° commande]=[Détails commandes].[N° commande]) ON 
[Employés].[N° employé]=[Commandes].[N° employé]) ON 
[Messagers].[N° messager]=[Commandes].[N° messager]) ON 
[Produits].[Réf produit]=[Détails commandes].[Réf produit];

Public Sub SauvegarderRqt(strFichier As String)
On Error Goto Err
Dim Db As DAO.Database
Dim qry As DAO.QueryDef
Dim FSO As New Scripting.FileSystemObject
Dim oFileText As Scripting.TextStream
'Instancie Db
Set Db = CurrentDb
'Ouvre le fichier texte (le crée s'il n'existe pas)
Set oFileText = FSO.OpenTextFile(strFichier, ForWriting, True)
'Pour chaque requête
For Each qry In Db.QueryDefs
  'si la requête n'est pas sytème (commence par ~)
  If Left(qry.Name, 1) <> "~" Then
    'Ecrit le nom de la requête et son code SQL
    With oFileText
      'Ecrit le titre et des #
      .WriteLine String(Len(qry.Name) + 4, "#")
      .WriteLine "# " & qry.Name & " #"
      .WriteLine String(Len(qry.Name) + 4, "#")
      'Saute 1 ligne et écrit le SQL
      .WriteBlankLines (1)
      .WriteLine qry.SQL
      'Saute 3 lignes
      .WriteBlankLines (3)
    End With
  End If
Next qry
'Ferme le fichier, libère la mémoire
oFileText.Close
Set FSO = Nothing
Db.Close
Set Db = Nothing
'Demande à l'utilisateur s'il veut visualiser le fichier
If MsgBox("Voulez vous ouvrir le fichier généré ?", _
  vbQuestion + vbYesNo, "Sauvegarde requête") = vbYes Then
  Shell "notepad.exe " & strFichier, vbMaximizedFocus
End If
Exit Sub
Err:
Msgbox "Une erreur est survenue."
End Sub

Option Compare Database
Option Explicit
 
Private Declare Function GetTickCount Lib _
  "kernel32" () As Long
 
Function PerformancePcTeste() As Currency
    Const curExposant           As Currency = 2
    Const lngDuréeMinima        As Currency = 100
    Dim intPuissance            As Integer
    Dim lngTopTemp              As Long
    Dim lngTopDébut             As Long
    Dim lngTopFin               As Long
    Dim lngDurée                As Long
    Dim curNombre               As Currency
    Dim curForIndex             As Currency
    Dim curNombreParSeconde     As Currency
    Dim curPuissance            As Currency
 
    Do
        intPuissance = intPuissance + 1
        curNombre = curExposant ^ intPuissance
        lngTopTemp = GetTickCount
        Do
            lngTopDébut = GetTickCount
        Loop Until lngTopDébut > lngTopTemp
 
        lngTopDébut = GetTickCount
        For curForIndex = 1 To curNombre
        Next       
        lngTopFin = GetTickCount
 
        lngDurée = lngTopFin - lngTopDébut
    Loop Until lngDurée > lngDuréeMinima
 
    curNombreParSeconde = curNombre / _
       lngDurée * 1000
    curPuissance = Log(curNombreParSeconde) / _
       Log(curExposant)
    curPuissance = Int(curPuissance * 100) / 100
    PerformancePcTeste = curPuissance
End Function

Function PerformancePcCompare _
       (PuissanceRéférence As Currency) As String
    Dim curPuissance            As Currency
 
    curPuissance = PerformancePcTeste()
    PerformancePcCompare = "La vitesse de ce PC est de " _
        & Int(2 ^ (curPuissance - PuissanceRéférence) * 100) / 100 _
        & " fois la vitesse du PC de référence"
End Function

Option Compare Database 
Option Explicit 
 
Private Declare Function GetTickCount Lib "kernel32" () As Long 
Private Nom As String 
Private Debut As Long 
Private Fin As Long 
 
Private Sub Class_Initialize() 
    Debut = GetTickCount 
End Sub 
 
Public Property Get lDebut() As Long 
    Let lDebut = Debut 
End Property 
 
Public Property Get lFin() As Long 
    Let lFin = Fin 
End Property 
 
Public Sub SetFin() 
    Fin = GetTickCount 
End Sub 
 
Public Function Duree() As Long 
    Duree = Fin - Debut 
End Function 
 
Public Sub lNom(ByVal pNom As String) 
   Nom = pNom 
End Sub 
 
Public Function getNom() As String 
    getNom = Nom 
End Function

Option Compare Database 
Option Explicit 
 
Dim Marqueurs As New Collection 
 
Private Sub Class_Initialize() 
    Set Marqueurs = New Collection 
End Sub 
 
Public Sub ajouterMarqueur(ByVal pNomMarqueur As String) 
    Marqueurs.Add New clsMarqueur, pNomMarqueur 
    Marqueurs(pNomMarqueur).lNom (pNomMarqueur) 
End Sub 
 
Public Sub terminerMarqueur(ByVal pNomMarqueur As String) 
    Marqueurs.Item(pNomMarqueur).SetFin 
End Sub 
 
Public Function dureeMarqueur(ByVal pNomMarqueur As String) As String 
    dureeMarqueur = Marqueurs.Item(pNomMarqueur).sDuree 
End Function 
 
Private Sub Class_Terminate() 
    Set Marqueurs = Nothing 
End Sub 
 
Public Sub rapportDebug() 
    Dim mqr As New clsMarqueur 
 
    For Each mqr In Marqueurs 
        Debug.Print mqr.getNom & " : " & mqr.Duree & "ms" 
    Next 
End Sub

Option Compare Database 
Option Explicit 
 
Sub TesterExemple() 
Dim cAnalyse As New clsMarqueurs 
 
cAnalyse.ajouterMarqueur "*** MettreAJourFax ***" 
Call MettreAJourFax 
cAnalyse.terminerMarqueur "*** MettreAJourFax ***" 
cAnalyse.rapportDebug 
End Sub 
 
Sub MettreAJourFax() 
Dim oRS As Recordset 
 
  Set oRS = CurrentDb.OpenRecordset("SELECT * FROM [Clients]", 2) 
    With oRS 
      If IsNull(.Fields("Fax")) Or Len(.Fields("Fax")) = 0 Then 
        .Edit 
          .Fields("Fax") = Null 
        .Update 
        .Close 
      End If 
    End With 
    Set oRS = Nothing 
End Sub

*** MettreAJourFax *** : 15547ms

' Intervalle du timer en millisecondes
Private Const INT_TIMER As Long = 1000
' Déclaration d'API pour timer
Private Declare Function APISetTimer Lib "user32.dll" Alias _
	"SetTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long, _
	 ByVal uElapse As Long, ByVal lpTimerProc As Long) As Long
Private Declare Function APIKillTimer Lib "user32.dll" Alias _
	"KillTimer" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
' Constante définissant les timers
Private Const IDT_TIMER As Long = 1
'Private Const IDT_TIMER2 As Long = 2
 
' Démarre le timer (numéro du timer, interval en ms)
Private Sub Start_Timer(nIDEvent As Long, interval As Long)
 
    APISetTimer Application.hWndAccessApp, nIDEvent, interval, _
		AddrOf("Callback_Timer") ' Ligne pour Access 97
    APISetTimer Application.hWndAccessApp, nIDEvent, interval, _
		AddressOf Callback_Timer ' Ligne pour les autres versions
 
End Sub
 
' Arrête le timer
Private Sub Stop_Timer(uIDEvent As Long)
 
    APIKillTimer Application.hWndAccessApp, uIDEvent
 
End Sub
 
' Callback_Timer est appelé par les timers à intervalle régulier
Public Function Callback_Timer(ByVal hWnd As Long, ByVal uMsg As Long, _
				ByVal wParam As Long, ByVal lParam As Long) As Long
' Citation de l'aide de AddressOf :
'Étant donné que l'appelant d'un rappel ne se trouve pas dans votre programme,
'il est important qu'une erreur rencontrée dans la procédure de rappel ne se propage pas
'dans l'appelant. Pour ce faire, insérez l'instruction On Error Resume Next
'au début de la procédure de rappel.
On Error Resume Next
 
    Select Case wParam
      Case IDT_TIMER
        Call Evenement_Timer
      'Case IDT_TIMER2
      '  Call Evenement_Timer2
    End Select
 
End Function
 
' Affichage de l'heure à chaque seconde
Private Sub Evenement_Timer()
 
    SysCmd acSysCmdSetStatus, Now()
 
End Sub
 
' Démarrage de l'horloge
Public Function Start_Test_Timer()
 
    Start_Timer IDT_TIMER, INT_TIMER
 
End Function
 
' Arrêt de l'horloge
Public Function Stop_Test_Timer()
 
    Stop_Timer IDT_TIMER
 
End Function