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 |
Partager