Zoom sur formulaire [Sources]

[Macc]

Bonjour,

je vous propose une source qui permet de redimensionner à l'échelle tous les controles présents dans un formulaire (y compris ceux des sous-formulaires) pour qu'ils prennent tous l'espace de la fenêtre active. Avec des grosses résolution, on évite ainsi d'avoir notre formulaire minuscule en haut à gauche de l'écran.

Code :

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
 
Option Compare Database
Option Explicit
 
'Mise en plein écran ou réduction à la taille d'origine
'du formulaire passé en paramètre
'Utilise la table Plein_Ecran
'
Function Plein_Ecran(pForm As Form, Optional pSens As String = "+")
 
DoCmd.Echo False
 
Dim vRatio As Variant
Dim i As Integer
Dim j As Integer
Dim vctl As Control
Dim vrst As Recordset
Dim vLargeurForm As Long
 
'calcul du ratio selon sens de redimmensionnement
'+stockage de la taille d'origine dans la propriété tag du formulaire
If pSens = "-" Then
    vRatio = 1 / ExtraitChaine(pForm.Tag, ";", 2)
    vLargeurForm = ExtraitChaine(pForm.Tag, ";", 3)
    pForm.Tag = ExtraitChaine(pForm.Tag, ";", 3) & ";1;" & ExtraitChaine(pForm.Tag, ";", 3)
Else
    If pForm.Tag = "" Then pForm.Tag = pForm.Width & ";" & 1 & ";" & pForm.Width 'largeur de référence
 
    'si la largeur d'origne du formulaire dépasse la largeur de l'écran, on ne redimensionne pas
    'les controles
    If ExtraitChaine(pForm.Tag, ";", 1) > (pForm.WindowWidth - 175) Then Exit Function
 
    vRatio = (pForm.WindowWidth - 175) / ExtraitChaine(pForm.Tag, ";", 1)
    pForm.Tag = pForm.WindowWidth - 175 & ";" & vRatio & ";" & ExtraitChaine(pForm.Tag, ";", 1)
End If
 
If vRatio = 1 Then Exit Function
 
'si affichage autre que mode formulaire: sortie
If pForm.CurrentView <> 1 Then Exit Function
 
'Sur agrandissement
'stock les dimenssions et emplacement de chaque controle dans une table locale
'afin de pouvoir trier l'ordre de redimenssionnement des controles et de replacer
'les controles exactement à leur place et dimension de départ en cas de réduction
If pSens = "+" Then
 
    CurrentDb.Execute "delete * from plein_ecran where nom_form='" & pForm.Name & "'"
 
    For Each vctl In pForm.Controls
            CurrentDb.Execute "Insert into plein_ecran (Nom_Form, Nom_controle, Section, [left], " & _
                "[top], [width], [height]) Values(" & _
                "'" & pForm.Name & "','" & vctl.Name & "'," & vctl.Section & "," & IIf(vctl.Left < 0, 0, vctl.Left) & "," & _
                IIf(vctl.Top < 0, 0, vctl.Top) & "," & IIf(vctl.Width < 0, 0, vctl.Width) & "," & _
                IIf(vctl.Height < 0, 0, vctl.Height) & ")"
    Next vctl
 
    'redimensionnement à l'échelle de toutes les sections (en-tête, détail, pied, etc.)
    Set vrst = CurrentDb.OpenRecordset("Select Section from plein_ecran where nom_form='" & pForm.Name & "'" & _
                                    "Group By Section Order by Section", dbOpenForwardOnly)
    While Not vrst.EOF
        pForm.Section(vrst!Section).Height = pForm.Section(vrst!Section).Height * vRatio
        vrst.MoveNext
    Wend
    vrst.Close
 
End If
 
'traitement du controle le plus indenté au controle le moins indenté
Set vrst = CurrentDb.OpenRecordset("Select * from plein_ecran where nom_form='" & pForm.Name & "'" & _
                                    "Order by [width]*[height]", dbOpenForwardOnly)
 
With vrst
    While Not .EOF
        Set vctl = pForm.Controls(!Nom_controle)
        If pSens = "-" Then
            vctl.Height = !Height
            vctl.Width = !Width
            vctl.Left = !Left
            vctl.Top = !Top
        Else
        i = 0
Recommence:
            'si le controle dépasse du formulaire, on le limite à la taille du formulaire (sinon erreur)
            If pForm.Section(vctl.Section).Height <= (!Height + !Top) * vRatio Then
                vctl.Height = pForm.Section(vctl.Section).Height - vctl.Top - 50
            Else
                vctl.Height = !Height * vRatio
            End If
 
            If pForm.WindowWidth <= (!Width + !Left) * vRatio Then
                vctl.Width = pForm.WindowWidth - vctl.Left - 50
            Else
                vctl.Width = !Width * vRatio
            End If
 
            If pForm.WindowWidth <= (!Width + !Left) * vRatio Then
                vctl.Left = pForm.WindowWidth - vctl.Width - 50
            Else
                vctl.Left = !Left * vRatio
            End If
 
            If vctl.Top <> !Top * vRatio Then
                If pForm.Section(vctl.Section).Height <= RoundUp(!Top * vRatio + vctl.Height) And !Top <> 0 Then
                    If pForm.Section(vctl.Section).Height - vctl.Height - 50 < 0 Then
                        vctl.Top = 0
                    Else
                        vctl.Top = pForm.Section(vctl.Section).Height - vctl.Height - 50
                    End If
                Else
                    vctl.Top = !Top * vRatio
                End If
            End If
 
            'tente 4 fois de suite d'appliquer les bonnes mesures
            '(1 fois pour chaque dimension)
            If (vctl.Top <> !Top * vRatio Or vctl.Left <> !Left * vRatio Or vctl.Height <> !Height * vRatio Or vctl.Width <> !Width * vRatio) And i < 4 Then
                i = i + 1
                GoTo Recommence
            End If
 
        End If
 
        'augmentation de la taille de police
        If Not (vctl.ControlType = acRectangle Or _
                vctl.ControlType = acOptionGroup Or _
                vctl.ControlType = acPage Or _
                vctl.ControlType = acCustomControl Or _
                vctl.ControlType = acCheckBox Or _
                vctl.ControlType = acImage Or _
                vctl.ControlType = acLine Or _
                vctl.ControlType = acOptionButton Or _
                vctl.ControlType = acSubform) Then vctl.FontSize = vctl.FontSize * vRatio
 
        'appel récursif pour les sous-formulaires
        If vctl.ControlType = acSubform Then Plein_Ecran vctl.Form, pSens
 
        .MoveNext
    Wend
    .Close
End With
 
 
If pSens = "-" Then
    Set vrst = CurrentDb.OpenRecordset("Select Section from plein_ecran where nom_form='" & pForm.Name & "'" & _
                                    "Group By Section Order by Section", dbOpenForwardOnly)
    While Not vrst.EOF
        pForm.Section(vrst!Section).Height = pForm.Section(vrst!Section).Height * vRatio
        vrst.MoveNext
    Wend
    vrst.Close
End If
 
DoCmd.Echo True
 
End Function
 
'Merci Philben ;-)
Public Function RoundUp(vValeur As Variant, Optional byNbDec As Byte) As Variant
   RoundUp = -Int(-vValeur * 10 ^ byNbDec) / 10 ^ byNbDec
End Function
 
'Extrait une chaine de pchaine séparée par pSeparateur
'en s'arrêtant à pNombre, ex:
'ExtraitChaine("premier/deuxieme/troisieme","/",2) retourne "deuxieme"
'retourne Null en cas d'erreur
Public Function ExtraitChaine(pChaine As String, pSeparateur As String, pNombre As Long) As String
 
    Dim vTab() As String
 
    vTab = Split(pChaine, pSeparateur, , vbTextCompare)
    If pNombre - 1 > UBound(vTab) Then Exit Function
 
    ExtraitChaine = vTab(pNombre - 1)
 
End Function

Comme tous code, celui-ci peut être amélioré et contient sûrement des lacunes mais il tourne.

J'ai joint une base d'exemple pour ceux qui veulent tester.

J'espère que cela vous sera utile.
A+

[Papy Turbo]

Excellent bout de code qui m'a beaucoup plu.
J'ai l'impression qu'il y a un petit problème avec le sous-formulaire qui ne s'agrandit pas autant que les composants qu'il contient ?
Sinon, conseil, côté gestion d'erreur : remplace au minimum ton Resume par un Resume Next. Ça évitera de se retrouver (comme moi ) dans une boucle sans fin...
Dans ce genre d'exercice, je conseillerais volontiers de ne mettre aucun code de contrôle d'erreur, sauf erreur spécifique connue. Mieux vaut
- ajouter chacun son propre code d'erreur,
- pendant les tests, voir la boîte de dialogue de VBA, qui propose, soi Fin, soit Débogage...

Ma question : Est-ce que tu as essayé de le rendre "interactif", à partir de Form_Resize, pour que la taille s'ajuste à chaque redimensionnement du formulaire (formulaires "élastiques") ?
Il faudrait probablement séparer les 2 fonctions incluses ici :
1- sous contrôle du développeur : remettre tous contrôles à la taille originale, modifier la disposition puis enregistrer les dimensions des contrôles,
2- à partir de ces dimensions figées dans la table, et de la taille de la fenêtre, redimensionner pendant le Form_Resize().

Enfin, toujours dans la même optique : autant ton appel récursif pour les sous-formulaires est excellent dans ton exemple, autant tu n'en aurais plus besoin. Chaque (sous-)formulaire ayant son propre FormResize qui se déclenche dès qu'on retaille le contrôle sous-formulaire qui le contient...

[Macc]

Envoyé par Papy Turbo

Sinon, conseil, côté gestion d'erreur : remplace au minimum ton Resume par un Resume Next. Ça évitera de se retrouver (comme moi ) dans une boucle sans fin...

Oups! restes de débuggage Je vais suivre ton consiel et retirer la gestion d'erreur

Ma question : Est-ce que tu as essayé de le rendre "interactif", à partir de Form_Resize, pour que la taille s'ajuste à chaque redimensionnement du formulaire (formulaires "élastiques") ?
Il faudrait probablement séparer les 2 fonctions incluses ici :
1- sous contrôle du développeur : remettre tous contrôles à la taille originale, modifier la disposition puis enregistrer les dimensions des contrôles,
2- à partir de ces dimensions figées dans la table, et de la taille de la fenêtre, redimensionner pendant le Form_Resize().

Non, je n'ai pas encore essayé, mais c'est une bonne suggestion, je m'y colle de suite..