Affichage d un formulaire sur deux écrans de taille différente

**adelsunwind** · 22/10/2008, 23h45

Bonsoir à tous,
j ai une application que j'ai développé sur un PC classique de bureau avec un écran de taille 18 pouces.
Maintenenant mon chef exige que cette application soit portable donc sur un PC portable donc sur un écran plus petit.
J ai donc tous mes formulaires qui débordent du cadre de l écran du PC portable.

Y a t il une astuce pour re-dimensionner automatiquement tous les formulaires de l'appli en fonction de la taille de l'écran du PC sur lequel je travaille ou dois je tous les refaire à la main pour les mettre à la bonne taille?

En esperant avoir été clair.
Merci

Invité · 23/10/2008, 05h34

Bonjour

Il n'y a pas de solution native dans Access pour cela.

Je te conseille d'aller jeter un coup d'œil dans le forum contribution, il y a des discussions intéressantes sur le sujet, comme ici : http://www.developpez.net/forums/d38...n-formulaires/

Philippe

**adelsunwind** · 28/10/2008, 16h18

Bonjoue,
je reviens vers les experts pour ce problème.
J ai essayé de travailler avec les messages de Domi2 et de seb92400.
J ai donc insérer le code comme convenu dans un module.
N ayant pas de sous formulaires en feuille de données j ai supprimé les procédures "proResolutionFD" et "proResolutionFD_Exit" du module ( Ai je bien fait? je na sais pas).
Je me retrouve donc avec le module suivant :

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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
 
Option Compare Database
Option Explicit
'
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Private Const HORZRES As Long = 8
Private Const VERTRES As Long = 10
Private Const HWND_DESKTOP = 0
 
Private Const ResolutionInitialeX = 1024
Private Const ResolutionInitialeY = 768
 
Private FactRedimX As Double
Private FactRedimY As Double
 
Private CoordsFD(0 To 255, 0 To 255) As Long
'
'
'###################################'
'                                   '
'          CODE RESOLUTION          '
'                                   '
'###################################'
Private 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
'
'
'
'##################################################'
'                                                  '
'          CODE REDIMENSIONNEMENT GENERAL          '
'                                                  '
'##################################################'
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
'

Déjà quand j essaie sur le même poste (1152*864) ou j ai développé l'application de la lancer j ai une erreur 6 : dépassement de capacité.
Ensuite si je passe sur le PC portable, rien ne se passe et j ai mes formulaires qui dépassent carrément de l'écran du portable.
Merci à tous d'avance pour vos conseils.

Affichage d un formulaire sur deux écrans de taille différente

IHM

Discussions similaires

Partager

Partager