Portabilité affichage macro VBA excel

**alexworks** · 07/10/2013, 09h07

Bonjour,

Je cherche une solution pour que l'affichage de ma macro de change pas d'un pc a un autre

j'ai fais mes écrans plutôt petit pour que selon la résolution d'affichage sa rentre toujours dans "la lucarne"

mais sur un autre pc les labels, combobox et tout le reste sont pas affichés on même endroit.

j'ai une photo de font et les fenêtres affiches des cotes mais comme tout bouges les cotes sont plus en face les bons endroits sur le dessin.

Merci de votre aide

**Daniel.C** · 07/10/2013, 09h43

Bonjour,

Les dimensions de la fenêtre sont données (en points) par :
- Application.Height (hauteur)
- Application.Width (largeur)
Si ça peut t'aider.

**alexworks** · 07/10/2013, 10h20

pour avoir comme un plein écran pour la fenêtre userform

j'ai mis ce code (sa marche):

Code :

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

1
2
3
4
5
With portailcoulis
       .StartUpPosition = 3
       .Width = Application.Width - 2
     .Height = Application.Height - 3
  End With

par contre sa me fige pas les textbox

**Daniel.C** · 07/10/2013, 10h34

Tu peux régler la taille de chaque contrôle comme celle des userforms.

**alexworks** · 07/10/2013, 11h07

comment tu peux definir la position de chaque controle?

**ben_ghost** · 07/10/2013, 11h18

avec les fonctions liés à la position de ton contrôle...

top, height, width et left

**alexworks** · 07/10/2013, 11h41

voila ce que je devrais avoir
et ce que j'ai
voir les pièces jointes

comment faire pour éviter sa.

je cherche mais je trouve rien a rajouter dans le code

**Daniel.C** · 07/10/2013, 12h19

1. la version d'Excel n'est pas 2003.
2. Est-ce que la résolution d'écran est la même sur tous les ordis ?

**alexworks** · 07/10/2013, 14h48

c'est excel2007
et la résolution est différente d'un écran a un autre

**Daniel.C** · 07/10/2013, 15h16

Je ne peux pas faire le test, mais google un peu avec les mots clé : "excel vba ecran resolution" ou "excel vba screen resolution" si tu comprends l'anglais.

Invité · 08/10/2013, 02h42

Bonsoir,

S'agit-il d'un problème similaire à ici http://www.developpez.net/forums/d13...m/#post7506283 ? Si oui, il y aurai éventuellement une solution mais par API.

A mettre dans 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
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
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
#If VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If
 
'***************************
'CONSTANTE GetSystemMetrics
'***************************
Private Const SM_CXSCREEN As Long = 0 'Récupère la Définition Horizontale en Largeur sur l'axe Y (résultat en pixel) de l'écran principal uniquement : Typiquement 1920 en HD
Private Const SM_CYSCREEN As Long = 1 'Récupère la Définition Verticale en Hauteur sur l'axe Y (résultat en pixel) de l'écran principal uniquement : Typiquement 1080 en HD
Private Const SM_CYCAPTION = 4 'Récupère la Hauteur de la barre de titre CAPTION
Private Const SM_CXBORDER = 5 ' Récupère la Largeur d'une bordure de fenêtre
Private Const SM_CYBORDER = 6 ' Récupère la Hauteur d'une bordure de fenêtre
Private Const SM_CYMENU = 15 'Récupère la Hauteur de la barre de menu
Private Const SM_CXSIZEFRAME = 32 ' Récupère l'épaisseur horizontale d'une bordure de fenêtre redimensionnable
Private Const SM_CYSIZEFRAME = 33 ' Récupère l'épaisseur verticale d'une bordure de fenêtre redimensionnable
Private Const SM_CMONITORS As Long = 80 'Récupère le nombres de moniteurs "visible"
 
'************************
'CONSTANTE GetDeviceCaps
'************************
Private Const LOGPIXELSX As Long = 88 'Récupère le nombre de Pixels Par Pouce Windows sur l'axe X (en largeur : horizontale)
Private Const LOGPIXELSY As Long = 90 'Récupère le nombre de Pixels Par Pouce Windows sur l'axe Y (en hauteur : verticale)
 
'Un point est défini comme 1/72 pouces
Private Const PPP_REF As Long = 72
 
#If Win64 Then
    Private Const HWND_DESKTOP As LongPtr = 0
#Else
    Private Const HWND_DESKTOP As Long = 0
#End If
 
'Mémorise le ppp
Private pppWindowsX As Long
Private pppWindowsY As Long
 
'La Définition horizontale (L) de l'écran, en pixels
Public Function DefX() As Long
    Static MémoDEF_X As Long
    If MémoDEF_X = 0 Then
        MémoDEF_X = GetSystemMetrics(SM_CXSCREEN)
        If MémoDEF_X = 0 Then
            DefX = 640
            Exit Function
        Else
            DefX = MémoDEF_X
            Exit Function
        End If
    Else
        DefX = MémoDEF_X
        Exit Function
    End If
End Function
 
Private Sub TestDefX()
MsgBox DefX
End Sub
 
'La Définition verticale (H) de l'écran, en pixels
Public Function DefY() As Long
    Static MémoDEF_Y As Long
    If MémoDEF_Y = 0 Then
        MémoDEF_Y = GetSystemMetrics(SM_CYSCREEN)
        If MémoDEF_Y = 0 Then
            DefY = 360
            Exit Function
        Else
            DefY = MémoDEF_Y
            Exit Function
        End If
    Else
        DefY = MémoDEF_Y
        Exit Function
    End If
End Function
 
Private Sub TestDefY()
MsgBox DefY
End Sub
 
' Retourne un Ratio entre le ppp de Windows (96 ppp par défaut) et le ppp de référence (72 ppp) sur l'axe X
Public Function pppRatioX(Optional MsgBoxSurErreur As Boolean = False) As Single
    #If VBA7 Then
        Dim hDC As LongPtr
    #Else
        Dim hDC As Long
    #End If
    Dim Recommencer As Byte
    Dim Erreur_GetDC As Boolean
    Dim Erreur_GetDeviceCaps As Boolean
 
    Do
        If pppWindowsX = 0 Then
            hDC = GetDC(HWND_DESKTOP)
            If hDC <> 0 Then
                pppWindowsX = GetDeviceCaps(hDC, LOGPIXELSX)
                ReleaseDC HWND_DESKTOP, hDC
                If pppWindowsX <> 0 Then
                    pppRatioX = CSng(pppWindowsX / PPP_REF)
                    Exit Function
                Else
                    Erreur_GetDeviceCaps = True
                    Recommencer = Recommencer + 1
                End If
            Else
                ReleaseDC HWND_DESKTOP, hDC
                Erreur_GetDC = True
                Recommencer = Recommencer + 1
            End If
        Else
            pppRatioX = CSng(pppWindowsX / PPP_REF)
            Exit Function
        End If
    Loop While Recommencer <= 10 And (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True)
 
    If (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True) = True Then
        pppWindowsX = 96
        pppRatioX = CSng(pppWindowsX / PPP_REF)
        If MsgBoxSurErreur = True Then
            MsgBox "Une erreur s'est produite lors de l'appel à la fonction 'GetDC' ou 'GetDeviceCaps', il se peut qu'une partie de l'affichage soit incorrecte." & Chr(10) & Chr(10) & _
                   "Une base de 96 ppp sur l'axe X sera pris en compte pour l'affichage.", vbInformation
        End If
    End If
 
End Function
 
Sub Test_pppRatioX()
MsgBox pppRatioX(True)
End Sub
 
' Retourne un Ratio entre le ppp de Windows (96 ppp par défaut) et le ppp de référence (72 ppp) sur l'axe Y
Public Function pppRatioY(Optional MsgBoxSurErreur As Boolean = False) As Single
    #If VBA7 Then
        Dim hDC As LongPtr
    #Else
        Dim hDC As Long
    #End If
    Dim Recommencer As Byte
    Dim Erreur_GetDC As Boolean
    Dim Erreur_GetDeviceCaps As Boolean
 
    Do
        If pppWindowsY = 0 Then
            hDC = GetDC(HWND_DESKTOP)
            If hDC <> 0 Then
                pppWindowsY = GetDeviceCaps(hDC, LOGPIXELSY)
                ReleaseDC HWND_DESKTOP, hDC
                If pppWindowsY <> 0 Then
                    pppRatioY = CSng(pppWindowsY / PPP_REF)
                    Exit Function
                Else
                    Erreur_GetDeviceCaps = True
                    Recommencer = Recommencer + 1
                End If
            Else
                ReleaseDC HWND_DESKTOP, hDC
                Erreur_GetDC = True
                Recommencer = Recommencer + 1
            End If
        Else
            pppRatioY = CSng(pppWindowsY / PPP_REF)
            Exit Function
        End If
    Loop While Recommencer <= 10 And (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True)
 
    If (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True) = True Then
        pppWindowsY = 96
        pppRatioY = CSng(pppWindowsY / PPP_REF)
        If MsgBoxSurErreur = True Then
            MsgBox "Une erreur s'est produite lors de l'appel à la fonction 'GetDC' ou 'GetDeviceCaps', il se peut qu'une partie de l'affichage soit incorrecte." & Chr(10) & Chr(10) & _
                   "Une base de 96 ppp sur l'axe Y sera pris en compte pour l'affichage.", vbInformation
        End If
    End If
 
End Function
 
Sub Test_pppRatioY()
MsgBox pppRatioY(True)
End Sub
 
' Retourne le ppp de Windows (96 ppp par défaut) sur l'axe X
Public Function pppX(Optional MsgBoxSurErreur As Boolean = False) As Long
    #If VBA7 Then
        Dim hDC As LongPtr
    #Else
        Dim hDC As Long
    #End If
    Dim Recommencer As Byte
    Dim Erreur_GetDC As Boolean
    Dim Erreur_GetDeviceCaps As Boolean
 
    Do
        If pppWindowsX = 0 Then
            hDC = GetDC(HWND_DESKTOP)
            If hDC <> 0 Then
                pppWindowsX = GetDeviceCaps(hDC, LOGPIXELSX)
                ReleaseDC HWND_DESKTOP, hDC
                If pppWindowsX <> 0 Then
                    pppX = pppWindowsX
                    Exit Function
                Else
                    Erreur_GetDeviceCaps = True
                    Recommencer = Recommencer + 1
                End If
            Else
                ReleaseDC HWND_DESKTOP, hDC
                Erreur_GetDC = True
                Recommencer = Recommencer + 1
            End If
        Else
            pppX = pppWindowsX
            Exit Function
        End If
    Loop While Recommencer <= 10 And (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True)
 
    If (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True) = True Then
        pppWindowsX = 96
        pppX = pppWindowsX
        If MsgBoxSurErreur = True Then
            MsgBox "Une erreur s'est produite lors de l'appel à la fonction 'GetDC' ou 'GetDeviceCaps', il se peut qu'une partie de l'affichage soit incorrecte." & Chr(10) & Chr(10) & _
                   "Une base de 96 ppp sur l'axe X sera pris en compte pour l'affichage.", vbInformation
        End If
    End If
 
End Function
 
Sub Test_pppX()
MsgBox pppX(True)
End Sub
 
' Retourne le ppp de Windows (96 ppp par défaut) sur l'axe X
Public Function pppY(Optional MsgBoxSurErreur As Boolean = False) As Long
    #If VBA7 Then
        Dim hDC As LongPtr
    #Else
        Dim hDC As Long
    #End If
    Dim Recommencer As Byte
    Dim Erreur_GetDC As Boolean
    Dim Erreur_GetDeviceCaps As Boolean
 
    Do
        If pppWindowsY = 0 Then
            hDC = GetDC(HWND_DESKTOP)
            If hDC <> 0 Then
                pppWindowsY = GetDeviceCaps(hDC, LOGPIXELSY)
                ReleaseDC HWND_DESKTOP, hDC
                If pppWindowsY <> 0 Then
                    pppY = pppWindowsY
                    Exit Function
                Else
                    Erreur_GetDeviceCaps = True
                    Recommencer = Recommencer + 1
                End If
            Else
                ReleaseDC HWND_DESKTOP, hDC
                Erreur_GetDC = True
                Recommencer = Recommencer + 1
            End If
        Else
            pppY = pppWindowsY
            Exit Function
        End If
    Loop While Recommencer <= 10 And (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True)
 
    If (Erreur_GetDC = True Or Erreur_GetDeviceCaps = True) = True Then
        pppWindowsY = 96 'Tanpis, après 10 erreurs, il vaut mieux sauvegarder temporairement 96 ppp
        pppY = pppWindowsY
        If MsgBoxSurErreur = True Then
            MsgBox "Une erreur s'est produite lors de l'appel à la fonction 'GetDC' ou 'GetDeviceCaps', il se peut qu'une partie de l'affichage soit incorrecte." & Chr(10) & Chr(10) & _
                   "Une base de 96 ppp sur l'axe Y sera pris en compte pour l'affichage.", vbInformation
        End If
    End If
 
End Function
 
Sub Test_pppY()
MsgBox pppY(True)
End Sub

Ensuite, en appelant DefX, tu auras la définition de ton écran sur l'axe X (en largeur - Horizontale), idem pour la hauteur avec DefY. Résultat en pixel.
Le nombre de ppp défini dans Windows est obtenu en appelant pppX pour l'axe X et idem pour l'axe Y avec pppY. Sinon, un ratio permet de trouver le nombre de points nécessaire dans la mesure où comme dit par Daniel.C, les UserForm parlent en points et veulent des points.
Nombre de points = DefX / ratiopppX te donneras le nombre de points équivalent à ton écran de PC ou d'un userform plein écran.

Des exemples d'appel des fonctions sont insérer dans le module, mais sinon, appel les comme suit depuis l'extérieur:

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
Private Sub TestDefX()
MsgBox DefX
End Sub
Private Sub TestDefY()
MsgBox DefY
End Sub
Private Sub Test_pppX()
MsgBox pppX(True)
End Sub
Private Sub Test_pppY()
MsgBox pppY(True)
End Sub
Private Sub Test_pppRatioX()
MsgBox pppRatioX(True)
End Sub
Private Sub Test_pppRatioY()
MsgBox pppRatioY(True)
End Sub

Ça ne marchera que sous Windows 2000 Professionnel minimum.

P.S.: Un userform en plein écran, peu importe le ppp ou la définition de l'écran est définit par:
Largeur = DefX/pppRatioX
Hauteur = DefY/pppRatioY

(mettre le top à 0 et le left à 0).

--------------------------------------------------------------------------------------------------------
Re:
Quelque soit l'écran ou ppp utilisateur, pour un userform prenant la moitié de l'écran sur X et Y (1/4 en surface), tu peux mettre à l'init:

Code :

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

1
2
3
4
5
6
Private Sub UserForm_Initialize()
    Me.Left = (1 / 4) * (DefX / pppRatioX)
    Me.Top = (1 / 4) * (DefY / pppRatioY)
    Me.Width = (1 / 2) * (DefX / pppRatioX)
    Me.Height = (1 / 2) * (DefY / pppRatioY)
End Sub

Re, en principe, ce n'est pas bien de faire ça. Un ppp plus grand que 96 est un choix de l'utilisateur qui souhaite avoir un texte ou des fenêtres plus grande qu'en 96 ppp (défaut). Sauf si la fenêtre est en plein écran.

Portabilité affichage macro VBA excel

Macros et VBA Excel

Discussions similaires

Partager

Partager