IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

Les meilleures sources Access

Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaireDiversAssistance au développement

Versions : 2000 et supérieures

Parfois certaines propriétés comme le texte de barre d'état sont fastidieuses à mettre à jour. Cette procédure permet de passer en revue tous les formulaires d'une application afin de mettre à jour la propriété StatusBarText des contrôles concernés. La valeur proposée par défaut correspond au nom du contrôle.

Pour utiliser cette procédure, copiez la dans un module. Puis, toujours dans VBE, affichez la fenêtre exécution (ctrl+G).
Dans cette fenêtre, tapez :

 
Sélectionnez
sStatusBarText

Code à placer dans le module :

 
Sélectionnez
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
Créé le 27 août 2004  par Fred.G

Versions : 2000 et supérieures

Ce code permet de lister l'ensemble des tables et des champs d'une base de données. Le résultat est envoyé dans un treeview ce qui permet d'avoir une vue globale des propriétés de l'ensemble des champs de la base de données.

 
Sélectionnez
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

Le processus est en fait très simple. Il s'agit de lire chaque table puis pour chaque table, accéder à chacun des champs et enfin, pour chaque champ, lire une à une les propriétés. La fonction renvoi_type permet d'afficher une valeur explicite du type du champ et non un numérique. Quant à la fonction lirePropriete, elle permet d'accéder à la valeur d'une propriété et ne pas faire boguer le programme principal si la propriété est inaccessible.

N'hésitez surtout pas à télécharger la base de données exemple en fichier Zip. Elle vous permet, en plus, de sélectionner une autre base de données que celle en cours d'utilisation.

Créé le 8 février 2005  par Maxence Hubiche

Page de l'auteur
Téléchargez le zip

Versions : Toutes

Ce code permet d'obtenir la description du champ passé en paramètre. Toutefois, pour que cela fonctionne, vous devez ajouter la référence Microsoft DAO Object Library à votre projet.

Attention !

Il semble que la propriété "Description" n'existe pas par défaut en DAO. Le fait d'exploiter cette fonction alors que la propriété (passée en paramètre) n'existe pas, va provoquer l'erreur 3270 (Propriété inexistante). Dans cet exemple, la propriété est créée s'il elle n'existe pas et si le paramètre "CreateIt" est égal à True.
Vous pouvez modifier ou adapter la fonction fnctGetFieldDescription selon vos besoins...

Dans un module, copiez la fonction suivante :

 
Sélectionnez
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

Exemple d'utilisation:

 
Sélectionnez
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

Nb :

Normalement, la case à cocher "Arrêt sur toutes les erreurs" n'est pas censée être cochée car par défaut, c'est la case à cocher "Arrêt sur les erreurs non gérées" qui l'est. Veillez à ce que vos options en VBA soient ainsi déclarées si un bug se présentait. Merci à CRUSOE13 pour cette remarque intéressante.

Créé le 8 octobre 2005  par Argyronet

Page de l'auteur

Versions : Access 2000 et supérieures

Parfois, lorsque vous reprennez le projet d'un autre développeur, vous avez besoin de réaliser le dictionnaire des données de la base afin d'avoir sous les yeux l'ensemble des champs (attributs) utilisés.

Cet exemple de code utilise la librairie Microsoft DAO (il vous faut donc ajouter cette référence) afin de parcourir la structure du fichier mdb.

L'ensemble du résultat est envoyé vers une table nommée Tbl_Dictionnaire que le module se chargera de créer si celle-ci n'existe pas.

Elle se compose des champs suivants :

  • Table : Nom de la table
  • Attribut : Nom du champ (attribut)
  • TypeAttribut : Type du champ
  • RegleGestion : Règle de gestion appliquée à la propriété Valide Si du champ

Le module dispose de trois fonctions utilitaires :

La première permet de tester l'existence d'une table :

 
Sélectionnez
'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

La seconde permet de traduire la propriété Type des champs DAO (Field) en texte :

 
Sélectionnez
'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

Enfin la dernière permet de mettre en forme du texte afin de pouvoir l'exécuter dans une requête. Elle encadre ainsi la chaine passée en paramètre par des guillemets et double ceux figurant à l'intérieur.

 
Sélectionnez
'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

Les procédures du dictionnaire sont les suivantes :

 
Sélectionnez
'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

CreerTableDico crée la table du dictionnaire où seront stockés les résultats. Dans le cas où la table existe déjà, elle se contente alors simplement de vider son contenu.

La procédure principale est alors la suivante :

 
Sélectionnez
'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

N'hésitez pas à télecharger le fichier zip afin de visualiser le résultat ainsi qu'un exemple d'état possible.

Créé le 12 novembre 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

Cet exemple recherche des chaînes de caractères contenues dans les requêtes stockées de la base courante et retourne une collection d'objets Querydef des requêtes correspondantes.

Pour que ce code fonctionne vous devez ajouter la référence Microsoft DAO Object Library à votre projet.

Dans un module, placez le code suivant :

 
Sélectionnez
'------------------------------
'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

Mode d'utilisation :

Vous prenez un projet en cours où règne la pagaille ou bien vous êtes un peu perdu dans votre propre projet. Vous ne savez plus par qui cette table est modifée ou vous cherchez à savoir dans quelles requêtes des tables sont utilisées...

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

Résultat obtenu dans la fenêtre de débogage :

 
Sélectionnez
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];
Créé le 8 octobre 2005  par vmolines

Version : Access 97 et supérieures

Pour que ce code fonctionne, vous devez ajouter les références suivantes à votre projet :

  • Microsoft Scripting Runtime
  • Microsoft DAO Object Library

Dans un module, placez le code suivant :

 
Sélectionnez
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

Ce code est particulièrement utile aux étudiants qui souhaitent rendre un rapport de leur projet et aux développeurs qui, comme moi, aiment garder une trace papier de leur travail.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Dans un réseau d'entreprise, il est utile de pouvoir rapatrier des infos sur les postes connectés (mémoire, résolution d'écran, OS, ...), mais il est délicat d'obtenir la vitesse du processeur. Pour pallier à ce manque, voici une fonction qui retourne une valeur indiquant la vitesse brute de la machine (durée d'une boucle for/next). Le résultat est donné en log base 2 pour atténuer les écarts de résultats. Avec cette méthode, un point supplémentaire indique une machine deux fois plus rapide. L'avantage de cette fonction c'est qu'elle permet de se faire tout de suite une idée de l'age de la machine.

 
Sélectionnez
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

Les plus lents PC que j'aie vu sur un réseau donnaient un résultat de 21-22 (P2) ce qui est aujourd'hui un veau. Mon PC, un Athlon 1400 (=1800) donne 25,5. Je n'ai pas encore vu de note supérieure ou égale à 27.

Je joins cette fonction qui permet de comparer son PC avec une note de référence :

 
Sélectionnez
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

- Je précise tout de même que pour obtenir une note fiable, il ne faut pas qu'un autre programme gourmand tourne en tâche de fond.
- La note de performance évolue très légèrement en fonction de la version du Basic - optimisations du compilateur ?

Créé le 5 mars 2005  par mathieuT

Versions : Access 2000 et supérieures

Un marqueur mesure le temps d'execution du code compris entre son début et sa fin. On peut utiliser plusieurs marqueurs et les imbriquer. Cette source se compose de 2 classes clsMarqueur et clsMarqueurs. Le développeur ne déclare et manipule que clsMarqueurs qui est une collection de plusieurs objets marqueurs.

Code Classe clsMarqueur

 
Sélectionnez
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

Code Classe clsMarqueurs

 
Sélectionnez
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

Exemple d'utilisation sur une procédure lente :

 
Sélectionnez
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

Valeurs renvoyées dans la fenêtre d'exécution :

 
Sélectionnez
*** MettreAJourFax *** : 15547ms
Créé le 8 octobre 2005  par vmolines

Le code suivant est à coller dans un module. En faisant varier nIDEvent on peut ajouter autant de timer que l'on veut sans être obligé de créer un formulaire caché. Pour l'exemple lancer la fonction Start_Test_Timer() Elle affiche l'heure dans la barre de statut...

Pour la version 97, utiliser la fonction AddrOf présente dans les sources. Cf lien.
Dans la procédure Start_Timer, pensez à supprimer la ligne qui ne correspond pas à votre version Access.

 
Sélectionnez
' 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

Lien : Code de remplacement de la fonction AddressOf pour Access 97

Créé le 16 janvier 2007  par Arkham46

Page de l'auteur

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.