Discussion :

[pgalipeau]

Salut à tous,

Je vous soumet un petit code qui permet d'envoyer la définition des contrôles de tous les formulaires créer vers un fichier excel.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
Public Sub ListFormsAndControls()
'Procédure...: ListFormsAndControls
'Par.........: Philippe Galipeau
'Description.: Retourne le nom des formulaire et la définition des objets
'............: dans un fichier excel.
'............:
 
'Déclaration des variable utilisé dans cette procédure
    Dim xlApp, wbExcel As Object
    Dim lRow As Long, lSheet As Long
    Dim i, iFormCount, iFormCountMax, iCtlCount, iCtlCountMax  As Integer
    Dim frmRead As Form
    Dim frmName, aStrControl(), strFichier_DEV As String
 
'Initialisation du lien avec excel
    Set xlApp = CreateObject("Excel.Application")
 
'PERSONNEL :
'  Les lignes suivant sont dans le but de pourvoir envoyez le résultat de la procédure
'  dans un ficheir de développement déjà existant.
'  Pour un lancement standard, dans un nouveau fichier utilisé l'initialisation suivante:
'      Set wbExcel = xlApp.Workbooks.Add
'      lSheet = 1
 
    strFichier_DEV = CurrentProject.Path & xlsxPath & "\" & _
                     appCode & "_Formulaires.xlsx"
 
    'Tester si fichier de développement existe
    If FileExists(strFichier_DEV) Then
        Set wbExcel = xlApp.Workbooks.Open(strFichier_DEV)
        wbExcel.Sheets.Add After:=wbExcel.Worksheets(wbExcel.Worksheets.Count)
        lSheet = wbExcel.Worksheets.Count
    Else
        Set wbExcel = xlApp.Workbooks.Add
        lSheet = 1
    End If
 
'Initialisation on error en cas qu'il n'y ai aucun formulaire
    On Error Resume Next
 
'Initialisation de l'entête dans la feuille d'excel
    lRow = 1
    With wbExcel.Sheets(lSheet)
        .Range("A" & lRow) = "FORMULAIRE"
        .Range("B" & lRow) = "OBJET"
        .Range("C" & lRow) = "TYPE"
        .Range("D" & lRow) = "CAPTION"
        .Range("E" & lRow) = "FONT"
        .Range("F" & lRow) = "FONTSIZE"
    End With
 
'Compter le nombre de formulaire
    iFormCountMax = CurrentProject.AllForms.Count
 
    'Passer en revue chaque formulaires
    For iFormCount = 0 To iFormCountMax - 1
        'Si le nom du formulaire ne contient pas les caratères ZZ
        'passe en revue les controles du formulaire
        If Left(CurrentProject.AllForms(iFormCount).Name, 2) <> "zz" Then
            frmName = CurrentProject.AllForms(iFormCount).Name
 
            'IMPORTANT: Le formulaire doit être ouvert pour lire les contrôles
            DoCmd.OpenForm frmName, acDesign, , , acFormReadOnly, acHidden
 
            Set frmRead = Forms(frmName)
 
            'Nombre de controls
            iCtlCountMax = frmRead.Count
 
            'Redimensionne le tableau
            ReDim aStrControl(0 To iCtlCountMax - 1, 0 To 5)
 
            'Passe en revue les contrôle et envois l'information dans le tableau
            For iCtlCount = 0 To iCtlCountMax - 1
 
                aStrControl(iCtlCount, 0) = frmName
                With frmRead(iCtlCount)
                    aStrControl(iCtlCount, 1) = .Name
                    Select Case frmRead(iCtlCount).ControlType
                        Case acLabel: aStrControl(iCtlCount, 2) = "Label"
                        Case acRectangle: aStrControl(iCtlCount, 2) = "Rectangle"
                        Case acLine: aStrControl(iCtlCount, 2) = "Line"
                        Case acImage: aStrControl(iCtlCount, 2) = "Image"
                        Case acCommandButton: aStrControl(iCtlCount, 2) = "Command Button"
                        Case acOptionButton: aStrControl(iCtlCount, 2) = "Option button"
                        Case acCheckBox: aStrControl(iCtlCount, 2) = "Check box"
                        Case acOptionGroup: aStrControl(iCtlCount, 2) = "Option group"
                        Case acBoundObjectFrame: aStrControl(iCtlCount, 2) = "Bound object frame"
                        Case acTextBox: aStrControl(iCtlCount, 2) = "Text Box"
                        Case acListBox: aStrControl(iCtlCount, 2) = "List box"
                        Case acComboBox: aStrControl(iCtlCount, 2) = "Combo box"
                        Case acSubform: aStrControl(iCtlCount, 2) = "SubForm"
                        Case acObjectFrame: aStrControl(iCtlCount, 2) = "Unbound object frame or chart"
                        Case acPageBreak: aStrControl(iCtlCount, 2) = "Page break"
                        Case acPage: aStrControl(iCtlCount, 2) = "Page"
                        Case acCustomControl: aStrControl(iCtlCount, 2) = "ActiveX (custom) control"
                        Case acToggleButton: aStrControl(iCtlCount, 2) = "Toggle Button"
                        Case acTabCtl: aStrControl(iCtlCount, 2) = "Tab Control"
                    End Select
                    aStrControl(iCtlCount, 3) = .Caption
                    aStrControl(iCtlCount, 4) = .FontName
                    aStrControl(iCtlCount, 5) = .FontSize
                End With
            Next iCtlCount
            'Fermer le formulaire
            DoCmd.Close acForm, frmName
 
            'Envois le tableau dans le ficheir excel
            For i = 0 To iCtlCount - 1
                lRow = lRow + 1
                With wbExcel.Sheets(lSheet)
                    .Range("A" & lRow) = aStrControl(i, 0)
                    .Range("B" & lRow) = aStrControl(i, 1)
                    .Range("C" & lRow) = aStrControl(i, 2)
                    .Range("D" & lRow) = aStrControl(i, 3)
                    .Range("E" & lRow) = aStrControl(i, 4)
                    .Range("F" & lRow) = aStrControl(i, 5)
                End With
            Next i
            Erase aStrControl
        End If
    Next iFormCount
 
    wbExcel.Sheets(lSheet).Name = "Définition des Objets"
    wbExcel.Sheets(lSheet).Columns.AutoFit
 
    On Error GoTo 0
 
    xlApp.Visible = True
    Set xlApp = Nothing
    Set wbExcel = Nothing
 
 
End Sub

Dit-moi ce que vous en penser.

[Jean-Philippe André]

Hello,

pas mal, mais je suis réticent à utiliser un On Error Resume Next

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
'Initialisation on error en cas qu'il n'y ai aucun formulaire
    On Error Resume Next

autant faire un test sur le nombre de formulaire dans la base en amont du code, c'est plus "propre" selon moi

[pgalipeau]

Tu as raison. Donc voici la correction à mettre au début de la procédure après les déclarations de variable:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
'TESTER: Si aucun formulaire existe, sortir de la procédure.
   If CurrentProject.AllForms.Count < 1 then
       Exit sub
   end if