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
| 'Ce module contrôle la propriété personalisée "Resolution" de la base de donnée, si elle est différente de la résolution de l'écran en cour, alors elle redimensionne le formulaire "frmManuResized" et met à jour la propriété "Resolution" de la base.
Option Compare Database
Option Explicit
'** Ratio = 0.8 '800*600 => 640*480
'** Ratio = 0.78125 '1024*768 => 800*600
'** Ratio = 0.625 '1024*768 => 640*480
'** Ratio = 1.25 '640*480 => 800*600
'** Ratio = 1.28 '800*600 => 1024*768
'** Ratio = 1.6 '640*480 => 1024*768
'** Déclaration des API
Public Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
(ByVal hDc As Long, ByVal nIndex As Long) As Long
Public Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hwnd As Long) As Long
Public Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hDc As Long) As Long
'** Déclaration des constantes
Public Const LOGPIXELSY = 90
Public Const LOGPIXELSX = 88
Public Const HorzRes = 8
Public Const VertRes = 10
Public Const HWND_DESKTOP = 0
Public Const SPI_GETWORKAREA = 48
'** Déclaration des variables
Public strRes As String
Public strResIni As String
Public ResHorzIni As Integer
Public ResVertIni As Integer
Public ResHorz As Integer
Public ResVert As Integer
Public RatioHorz As Single
Public RatioVert As Single
Public Function EXE_UpDateRes(strForm As String)
'** Utilises la fonction : "ResEcran()"
'** Utilises la fonction : "IniVariableRes()"
'** Utilises la fonction : "CalculRatio()"
Dim db As Database
Dim prp As Property
Dim cnt As Container
Dim doc As Document
Dim strMsg As String
Set db = CurrentDb: Set cnt = db.Containers!Databases
Set doc = cnt.Documents!UserDefined
InitPropRes
With doc
strResIni = .Properties("Résolution")
strRes = ResEcran()
If strRes <> strResIni Then
strMsg = "Votre résolution est différente de celle utilisée " _
& "lors du développement de cette application." _
& vbCrLf & vbCrLf & "Résolution lors du développement :" _
& vbCrLf & vbCrLf & vbTab & "- " & strResIni _
& vbCrLf & vbCrLf & "Résolution de votre poste :" _
& vbCrLf & vbCrLf & vbTab & "- " & strRes _
& vbCrLf & vbCrLf & "Voulez-vous que l'application " _
& "mette à jour la résolution de tous les formulaires " _
& "de l'application à jour ?"
If MsgBox(strMsg, vbYesNo, "Modification de la résolution") _
= vbYes Then
IniVariableRes
CalculRatio
Dim gdb As New classGridBag
DoCmd.OpenForm strForm, acDesign
gdb.InitForm Forms(strForm)
gdb.ReSizeForm Forms(strForm)
DoCmd.Close acForm, strForm, acSaveYes
gdb.DestroyForm: Set gdb = Nothing
EditPropRes
End If
End If
End With
End Function
Public Function apiHauteurEcran()
'** Résolution verticale de l'écran
Dim hDc As Long
hDc = apiGetDC(HWND_DESKTOP)
apiHauteurEcran = apiGetDeviceCaps(hDc, VertRes)
apiReleaseDC HWND_DESKTOP, hDc
End Function
Public Function apiLargeurEcran()
'** Résolution horizontale de l'écran
Dim hDc As Long
hDc = apiGetDC(HWND_DESKTOP)
apiLargeurEcran = apiGetDeviceCaps(hDc, HorzRes)
apiReleaseDC HWND_DESKTOP, hDc
End Function
Public Function apiLOGPIXELSX()
Dim hDc As Long
hDc = apiGetDC(HWND_DESKTOP)
apiLOGPIXELSX = apiGetDeviceCaps(hDc, LOGPIXELSX)
apiReleaseDC HWND_DESKTOP, hDc
End Function
Public Function apiLOGPIXELSY()
Dim hDc As Long
hDc = apiGetDC(HWND_DESKTOP)
apiLOGPIXELSY = apiGetDeviceCaps(hDc, LOGPIXELSY)
apiReleaseDC HWND_DESKTOP, hDc
End Function
Public Function ResEcran() As String
'** Donne la résolution en cours de l'écran
ResEcran = apiLargeurEcran & " x " & apiHauteurEcran & " (" & apiLOGPIXELSX & "x" & apiLOGPIXELSY & ")"
End Function
Public Sub CalculRatio()
'** Déterminer l'échelle d'agrandissement
RatioHorz = ResHorz / ResHorzIni
RatioVert = ResVert / ResVertIni
End Sub
Public Function IniVariableRes()
'** Initialise les variables concernant les résolutions
ResHorz = apiLargeurEcran
ResVert = apiHauteurEcran
ResHorzIni = Left(strResIni, InStr(strResIni, "x") - 2)
ResVertIni = Mid(strResIni, InStr(strResIni, "x") + 2, _
(InStr(strResIni, "(") - 1) - (InStr(strResIni, "x") + 2))
End Function
Public Function EditPropRes()
'** Modifie la propriétés personnalisé : "Résolution"
'** de la base de donnée en cours
'** Utilises la fonction : "ResEcran()"
Dim db As Database
Dim prp As Property
Dim cnt As Container
Dim doc As Document
Set db = CurrentDb: Set cnt = db.Containers!Databases
Set doc = cnt.Documents!UserDefined
With doc
.Properties("Résolution") = ResEcran()
End With
End Function
Sub InitPropRes()
Dim db As Database
Dim prp As Property
Dim cnt As Container
Dim doc As Document
Dim lngErreur As Long
Dim strTemp As String
Set db = CurrentDb: Set cnt = db.Containers!Databases
Set doc = cnt.Documents!UserDefined
With doc
On Error Resume Next
strTemp = .Properties("Résolution")
lngErreur = Err.Number
On Error GoTo 0
If lngErreur = 3270 Then ' Propriété non trouvée.
Set prp = .CreateProperty("Résolution", dbText, "xxx")
.Properties.Append prp
End If
End With
End Sub |
Réajuster automatiquement le format d' une BDD access sur differents ecrans PC
Répondre avec citation
Envoyé par facteur
. Peut-être ce ne sont pas les bons paramètres à modifier
Partager