dimensionnemment auto des form en fonction de la taille de l'écran

**adelsunwind** · 16/12/2009, 14h29

bonjour a tous,
j ai terminé mon outil développé en Access 2003. Elle tourne bien sur des PC de bureaux.J'ai donc dimensionné tous mes contrôles ( graphiques, zone de textes, onglets...) pour que l'utilisateur navigue aisément dans l'application.
Sauf que mon chef me demande de l'exporter sur PC portable pour que l'outil serve dans le cadre de la formation.
Moi je me dis facile je l'installe sur un PC portable et là catastrophe tous mes formulaires ( soit 40 ) sortent du cadre de l'écran et il faut utiliser les ascenseurs pour parcourir tout le contenu du formulaire.
Quelqu'un a-t-il une idée ou une source pour que le dimensionnement de mes form ainsi que des contrôles se fassent automatiquement en fonction de la taille de l'écran ou de sa résolution. Je crains de voir reprendre les form un à un et refaire tout le dimensionnement à la main.
Merci d'avance de vos conseils .

Invité · 16/12/2009, 18h06

Bonjour

Un peu de lecture : http://www.developpez.net/forums/d38...n-formulaires/

Philippe

**stigma** · 17/12/2009, 17h26

Mon code brut de pomme. En fait il n'est pas de moi, ça fait un moment que je l'utilise.

Code :

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

1
2
3
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Function GetLargeurEcran() As Integer
 
    '---------------  Résolution de travail
    GetLargeurEcran = apiGetSys(16)
    If GetLargeurEcran < 1024 Then
        MsgBox "Attention, la résolution de votre écran devrait" & vbCrLf & "" _
        & "être au minimum de 1024 x 768 afin que les" & vbCrLf & "" _
        & "formulaires soient visibles en totalité." & vbCrLf + vbCrLf & "" _
        & "Conseil : Consultez un ophtalmologiste ou changez de PC", vbExclamation, "PROBLEME RESOLUTION"
 
        Call Quitter
    End If
 
End Function

Avec ça tu devrais avancer. C'est juste un début de piste. J'avais vu un code qui redimensionnait tous les contrôles, mais bonjour la complexité !

**adelsunwind** · 21/12/2009, 15h12

Re-bonjour merci le post precedent
Je me suis vite empressé des reception du post de le tester mais ca marche pas enfin chez moi sur du Access2003.

J ai mis ca ds un module :

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
 :
 
Option Compare Database
Option Explicit
 
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Public Const HORZRES As Long = 8
Public Const VERTRES As Long = 10
Public Const HWND_DESKTOP = 0
 
Public Const ResolutionInitialeX = 1280
Public Const ResolutionInitialeY = 960
 
Public FactRedimX As Double
Public FactRedimY As Double
 
Public CoordsFD(0 To 255, 0 To 255) As Long

en passant tous les privées en public.
J ai developpée et dimensionné sur une machine avec la resolution vue au dessous ( 1280*960)

Maintenant l appli est sur mon portable ( (1024*768)

Dans le form du démarrage j ai mis :

Code :

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

1
2
3
4
5
6
:
 
 
Public Sub Form_Open(Cancel As Integer)
    proResolution Me '   
End Sub

et ds le meme form j ai mis

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
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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
 :
 
Public Sub proResolution(ByRef frmRedim As Form)
On Error GoTo Erreur_proResolution
 
    Dim LargeurFormulaire As Long
    Dim HauteurFormulaire As Long
 
    Dim numControle As Integer
    Dim typeControle As Variant
 
    'Os : Objets spéciaux...
    Dim Os As Boolean 'Passe à Oui si des Os sont détectés (sauf pour OsSection, toujours présents)...
    Dim OsCompteur As Integer
 
    Dim OsSection(0 To 20) As Integer 'Nombre de sections possibles dans le formulaire (!), 21 est déjà pas mal ;-)...
 
    Dim OsNom(0 To 255) As String 'Nombre d'Os possible par formulaire (chaîne)...
    Dim OsCoords(0 To 255, 1 To 6) As Double 'Coordonnéees des Os...
 
    Dim OsColonnes(0 To 255) As String 'Largeur des colonnes pour les listes (chaînes)...
    Dim OsCarColonnes(0 To 255) As Long 'Nombre de caractères pour la chaîne OsColonnes...
    Dim OsPositionCar As Integer 'Position du caractère ";" dans la chaîne OsColonnes...
    Dim OsNombreColonnes As Integer 'Nombre de colonnes à redimensionner...
    Dim OsDimensionColonne(0 To 255) As String 'Dimensions de chaque colonne des listes...
    Dim OsRedimColonnes As String 'Redimensionnement des colonnes...
 
    Dim FactRedimPolice As Double
 
'Calcul des facteurs de redimensionnement, "enregistrement" des hauteurs des sections,
'et initialisation de la variable Os...
    ResolutionActuelle
    LargeurFormulaire = frmRedim.InsideWidth
    For OsCompteur = 0 To 20
        OsSection(OsCompteur) = frmRedim.Section(OsCompteur).Height
    Next
    Os = False
 
'Surdimensionnement (x2) du formulaire afin d'éviter l'erreur 2100 lors du redimensionnement des onglets...
    'Largeur...
    frmRedim.InsideWidth = LargeurFormulaire * 2
    'Hauteur...
    HauteurFormulaire = 0
    For OsCompteur = 0 To 20
        HauteurFormulaire = HauteurFormulaire + OsSection(OsCompteur)
        frmRedim.Section(OsCompteur).Height = OsSection(OsCompteur) * 2
    Next
    frmRedim.InsideHeight = HauteurFormulaire * 2
 
'Lecture des contrôles du formulaire à la recherche des Os !! (normalement 206 dans le corps humain)...
    For numControle = 0 To (frmRedim.Controls.Count - 1)
        typeControle = frmRedim.Controls(numControle).ControlType
        Select Case typeControle
            Case acOptionGroup, acPage
                Os = True
                With frmRedim.Controls(numControle)
                    OsNom(numControle) = .Name
                    OsCoords(numControle, 1) = .Left
                    OsCoords(numControle, 2) = .Top
                    OsCoords(numControle, 3) = .Width
                    OsCoords(numControle, 4) = .Height
                End With
            Case acTabCtl
                Os = True
                With frmRedim.Controls(numControle)
                    OsNom(numControle) = .Name
                    OsCoords(numControle, 1) = .Left
                    OsCoords(numControle, 2) = .Top
                    OsCoords(numControle, 3) = .Width
                    OsCoords(numControle, 4) = .Height
                        '1 à 4 : Left, Top, Width, Height de tous les contrôles Os...
                    OsCoords(numControle, 5) = .TabFixedWidth
                    OsCoords(numControle, 6) = .TabFixedHeight
                        '5 à 6 : Largeur et hauteur des étiquettes des contrôles Os onglets...
                End With
            Case acComboBox, acListBox
                Os = True
                With frmRedim.Controls(numControle)
                    OsNom(numControle) = .Name
                    OsColonnes(numControle) = .ColumnWidths
                    OsCarColonnes(numControle) = Len(.ColumnWidths)
                End With
        End Select
    Next
 
'Redimensionnement des contrôles...
    'Placement de tous les contrôles, sauf les onglets et les pages d'onglets...
    For numControle = 0 To (frmRedim.Controls.Count - 1)
        typeControle = frmRedim.Controls(numControle).ControlType
        Select Case typeControle
            Case acTabCtl, acPage
            Case Else
            frmRedim.Controls(numControle).Move Left:=frmRedim.Controls(numControle).Left * FactRedimX, _
                                                Top:=frmRedim.Controls(numControle).Top * FactRedimY
        End Select
    Next
 
    'Redimensionnement des contrôles...
    For numControle = 0 To (frmRedim.Controls.Count - 1)
        typeControle = frmRedim.Controls(numControle).ControlType
        Select Case typeControle
            Case acOptionGroup, acPage 'Os
                If Os = True Then
                    frmRedim.Controls(numControle).Move Left:=OsCoords(numControle, 1) * FactRedimX, _
                                                        Top:=OsCoords(numControle, 2) * FactRedimY, _
                                                        Width:=OsCoords(numControle, 3) * FactRedimX, _
                                                        Height:=OsCoords(numControle, 4) * FactRedimY
                End If
            Case acTabCtl 'Os
                If Os = True Then
                    frmRedim.Controls(numControle).TabFixedWidth = OsCoords(numControle, 5) * FactRedimX
                    frmRedim.Controls(numControle).TabFixedHeight = OsCoords(numControle, 6) * FactRedimY
                    frmRedim.Controls(numControle).Move Left:=OsCoords(numControle, 1) * FactRedimX, _
                                                        Top:=OsCoords(numControle, 2) * FactRedimY, _
                                                        Width:=OsCoords(numControle, 3) * FactRedimX, _
                                                        Height:=OsCoords(numControle, 4) * FactRedimY
                End If
            Case acComboBox, acListBox 'Os
                If Os = True Then
                    frmRedim.Controls(numControle).Move Left:=frmRedim.Controls(numControle).Left, _
                                                        Top:=frmRedim.Controls(numControle).Top, _
                                                        Width:=frmRedim.Controls(numControle).Width * FactRedimX, _
                                                        Height:=frmRedim.Controls(numControle).Height * FactRedimY
                    'Si des dimensions ont été renseignées à la création des listes...
                    If OsCarColonnes(numControle) > 0 Then
                        OsNombreColonnes = 1
                        'Test de la variable dimensions à la recherche des ";"...
                        For OsCompteur = 1 To OsCarColonnes(numControle)
                            OsPositionCar = InStr(OsCompteur, OsColonnes(numControle), ";", vbTextCompare)
                            If OsPositionCar <> 0 Then
                                OsNombreColonnes = OsNombreColonnes + 1
                                OsCompteur = OsPositionCar + 1
                            End If
                        Next
                    OsRedimColonnes = ""
                    'Redimensionne chaque colonne...
                    For OsCompteur = 0 To OsNombreColonnes - 1
                        OsDimensionColonne(OsCompteur) = Split(OsColonnes(numControle), ";")(OsCompteur)
                        'Si colonne non renseignée (sauf la dernière), elle est égale à zéro...
                        If Len(OsDimensionColonne(OsCompteur)) = 0 Then OsDimensionColonne(OsCompteur) = "0"
                        OsDimensionColonne(OsCompteur) = CDbl(OsDimensionColonne(OsCompteur)) * FactRedimX
                        OsRedimColonnes = OsRedimColonnes & OsDimensionColonne(OsCompteur) & ";"
                    Next
                    frmRedim.Controls(numControle).ColumnWidths = Left(OsRedimColonnes, Len(OsRedimColonnes) - 1)
                                                                  'Enlève le dernier ";"...
                    End If
                End If
            Case acOptionButton, acCheckBox 'Contrôles non redimensionnables...
                'La longueur ("virtuelle") est redimensionnée afin d'éviter au texte d'être trop collé...
                frmRedim.Controls(numControle).Move Left:=frmRedim.Controls(numControle).Left, _
                                                    Top:=frmRedim.Controls(numControle).Top, _
                                                    Width:=frmRedim.Controls(numControle).Width * FactRedimX, _
                                                    Height:=frmRedim.Controls(numControle).Height
            Case Else 'Tous les autres contrôles...
                frmRedim.Controls(numControle).Move Left:=frmRedim.Controls(numControle).Left, _
                                                    Top:=frmRedim.Controls(numControle).Top, _
                                                    Width:=frmRedim.Controls(numControle).Width * FactRedimX, _
                                                    Height:=frmRedim.Controls(numControle).Height * FactRedimY
        End Select
    Next
 
   'Redimensionnement des polices...
    FactRedimPolice = (IIf(FactRedimX > FactRedimY, FactRedimY, FactRedimX))
    For numControle = 0 To (frmRedim.Controls.Count - 1)
        typeControle = frmRedim.Controls(numControle).ControlType
        Select Case typeControle
            Case acOptionGroup, acPage, acRectangle, acLine, acCheckBox, acOptionButton, acImage, acCustomControl, _
                acSubform, acPageBreak, acBoundObjectFrame, acObjectFrame
                'Contrôles n'ayant pas de police...
            Case Else
                frmRedim.Controls(numControle).FontSize = frmRedim.Controls(numControle).FontSize * FactRedimPolice
        End Select
    Next
 
'Redimensionnement final du formulaire après redimensionnement des contrôles...
    'Largeur...
    frmRedim.InsideWidth = LargeurFormulaire * FactRedimX
    'Hauteur...
    HauteurFormulaire = 0
    For OsCompteur = 0 To 20
        HauteurFormulaire = HauteurFormulaire + OsSection(OsCompteur)
        frmRedim.Section(OsCompteur).Height = OsSection(OsCompteur) * FactRedimY
    Next
    frmRedim.InsideHeight = HauteurFormulaire * FactRedimY
 
Sortie_proResolution:
    Exit Sub
 
Erreur_proResolution:
    If err.Number = 2462 Or err.Number = 438 Or err.Number = 2100 Then
        '2462 : Section inexistante, 438 : Propriété non gérée (polices), 2100 : Dépassement de capacité...
        err.Clear
        Resume Next
    Else
        MsgBoxPlusErreur "modResolution", "proResolution", CStr(err.Number), err.Description
        err.Clear
        Resume Sortie_proResolution
    End If
 
End Sub

puis j ai mis ds le meme formulaire

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
 :
 
 Public Sub ResolutionActuelle()
'On Error GoTo Erreur
 
    Dim hdc As Long
    Dim ResolutionActuelleX As Long
    Dim ResolutionActuelleY As Long
    Dim RatioX As Double
    Dim RatioY As Double
 
    'Donne la résolution actuelle en pixels...
    hdc = GetDC(HWND_DESKTOP)
    ResolutionActuelleX = GetDeviceCaps(hdc, HORZRES)
    ResolutionActuelleY = GetDeviceCaps(hdc, VERTRES)
    ReleaseDC HWND_DESKTOP, hdc
 
    'Facteur de redimensionnement...
    FactRedimX = ResolutionActuelleX / ResolutionInitialeX
    FactRedimY = ResolutionActuelleY / ResolutionInitialeY
 
    'Ratio permettant d'agrandir légèrement les contrôles et les formulaires pour un facteur
    'inférieur ou égale à 1 (exemple : Initiale 1024 x 768, Actuelle 800 x 600)
    'afin de rendre certaines polices ou certains contrôles lisibles...
    'Il est IMPORTANT de vérifier constamment qu'un formulaire agrandi ne dépasse pas de la zone écran !!!
    RatioX = FactRedimX / FactRedimY
    RatioY = FactRedimY / FactRedimX
    If (ResolutionActuelleX <> ResolutionInitialeX) Or (ResolutionActuelleY <> ResolutionActuelleY) Then
        If RatioX <= 1 Then FactRedimX = FactRedimX * 1.1
        If RatioY <= 1 Then FactRedimY = FactRedimY * 1.05
    End If
 
'Sortie:
  '  Exit Sub
 
'Erreur:
 '   MsgBoxPlusErreur "modResolution", "ResolutionActuelle", CStr(err.Number), err.Description
  '  err.Clear
  '  Resume Sortie
 
End Sub

Sauf qu on lancement il me met "Erreur de compilation-erreur ambigu detecté : FactRedimX" donc sur la variable FactRedimX
quelqu un sait il pourquoi???? et comment corriger cela?
merci

dimensionnemment auto des form en fonction de la taille de l'écran

IHM

Discussions similaires

Partager

Partager