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

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