Auteur : Fred.G
| | Version : 27/08/2004 | | |
| | 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 :
Code à placer dans le module : 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
Select Case MsgBox(Formulaire : " & obj.Name, vbQuestion + vbYesNoCancel)
Case vbYes
DoCmd.OpenForm obj.Name, acDesign
Set frm = Forms(obj.Name)
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
DoCmd.Close acForm, obj.Name, acSaveYes
Case vbCancel
Exit Sub
End Select
Next obj
set variable = nothing
End Sub |
|
| | 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. Private Sub Commande1_Click()
On Error Resume Next
Dim Pere As String
Dim T As DAO.TableDef
Dim F As DAO.Field
Dim P As DAO.Property
Dim DB As DAO.Database
TreeView0.Nodes.Clear
For Each T In DB.TableDefs
If T.Attributes = 0 Or (T.Attributes <> 0 And Me.chk_systeme) Then
TreeView0.Nodes.Add , , T.Name, T.Name
For Each F In T.Fields
Pere = T.Name
TreeView0.Nodes.Add Pere, tvwChild, Pere & "#" & _
F.Name, F.Name
Pere = Pere & "#" & F.Name
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
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
Private Function LireProperty(Objet As Object, _
Propriete As String) As String
On Error GoTo err
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.
|
| |
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 :
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:
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.
|
| |
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 :
Private Function TableExiste(strNom As String, _
oDb As DAO.Database) As Boolean
On Error GoTo err
Dim oTbl As DAO.TableDef
Set oTbl = oDb.TableDefs(strNom)
TableExiste = True
Set oTbl = Nothing
err:
End Function |
La seconde permet de traduire la propriété Type des champs DAO (Field) en texte :
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.
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 :
Private Sub CreerTableDico(oDb As DAO.Database)
Dim oTbl As DAO.TableDef
Dim oFld As DAO.Field
If Not TableExiste(NOMTABLEDICO, oDb) Then
Set oTbl = oDb.CreateTableDef(NOMTABLEDICO)
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)
oFld.AllowZeroLength = True
.Fields.Append oFld
End With
oDb.TableDefs.Append oTbl
Else
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 :
Public Sub EnrichirDico()
Dim oDb As DAO.Database
Dim oTbl As DAO.TableDef
Dim oFld As DAO.Field
Set oDb = CurrentDb
CreerTableDico oDb
For Each oTbl In oDb.TableDefs
If (oTbl.Attributes And dbSystemObject) = 0 And oTbl.Name <> NOMTABLEDICO Then
For Each oFld In oTbl.Fields
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
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.
|
| |
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 :
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
Set Db=CurrentDb
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...
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 :
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]; |
|
| |
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 :
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
Set Db = CurrentDb
Set oFileText = FSO.OpenTextFile(strFichier, ForWriting, True)
For Each qry In Db.QueryDefs
If Left(qry.Name, 1) <> "~" Then
With oFileText
.WriteLine String(Len(qry.Name) + 4, "#")
.WriteLine "# " & qry.Name & " #"
.WriteLine String(Len(qry.Name) + 4, "#")
.WriteBlankLines (1)
.WriteLine qry.SQL
.WriteBlankLines (3)
End With
End If
Next qry
oFileText.Close
Set FSO = Nothing
Db.Close
Set Db = Nothing
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.
|
| | 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.
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 :
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 ?
|
| |
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
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
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 :
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 :
*** MettreAJourFax *** : 15547ms |
|
 
|
