[IHM] Gérer la résolution des formulaires

[seb92400]

Hello,

Voici un code à placer dans un module... Il permet de détecter la résolution actuelle de l'écran et de redimensionner en fonction de la résolution de développement.

Ca existait déjà, les petits + sont :
+ Gestion des contrôles spéciaux : Onglets, boutons radios, listes, sections...
+ Lisibilité améliorée des polices (par un léger agrandissement à prendre en compte lors de la création)
+ Gestion des résolutions plus élevées, mais aussi plus petites
+ Gestion des contrôles ActiveX (Comme le calendrier. Attention toutefois, les polices de celui-ci étant intégrées, il arrive que pour certaines résolutions, le texte de la date disparaisse s'il est trop petit, comme le Calendrier, par exemple. mais c'est à prendre à compte lors de la conception)...

Voici le code. Je suis ouvert à toutes les remarques et à tous les bugs PS : Comme c'est la première que je poste ici, soyez indulgent, hein ???

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
'
'
'
'#############################################################'
'                                                             '
'          CODE REDIMENSIONNEMENT FEUILLE DE DONNEES          '
'                                                             '
'#############################################################'
Public Sub proResolutionFD(ByRef frmRedim As Form)
On Error GoTo Erreur_proResolutionFD
 
    Dim numControle As Integer
 
    For numControle = 0 To frmRedim.Controls.Count - 1
        Select Case frmRedim.Controls(numControle).ControlType
            Case 109 '109 : Contrôle colonne...
                CoordsFD(frmRedim.Count, numControle) = frmRedim.Controls(numControle).ColumnWidth
                frmRedim.Controls(numControle).ColumnWidth = frmRedim.Controls(numControle).ColumnWidth * FactRedimX
            End Select
    Next
 
Sortie_proResolutionFD:
    Exit Sub
 
Erreur_proResolutionFD:
    If Err.Number = 438 Then '438 : Propriété non gérée (colonnes)...
        Err.Clear
        Resume Next
    Else
        MsgBoxPlusErreur "modResolution", "proResolutionFD", CStr(Err.Number), Err.Description
        Err.Clear
        Resume Sortie_proResolutionFD
    End If
 
End Sub
'
'
'
Public Sub proResolutionFD_Exit(ByRef frmRedim As Form)
On Error GoTo Erreur_proResolutionFD_Exit
 
    Dim numControle As Integer
 
    For numControle = 0 To frmRedim.Controls.Count - 1
        Select Case frmRedim.Controls(numControle).ControlType
            Case 109 '109 : Contrôle colonne...
                frmRedim.Controls(numControle).ColumnWidth = CoordsFD(frmRedim.Count, numControle)
            End Select
    Next
 
Sortie_proResolutionFD_Exit:
    Exit Sub
 
Erreur_proResolutionFD_Exit:
    If Err.Number = 438 Then '438 : Propriété non gérée (colonnes)...
        Err.Clear
        Resume Next
    Else
        MsgBoxPlusErreur "modResolution", "proResolutionFD_Exit", CStr(Err.Number), Err.Description
        Err.Clear
        Resume Sortie_proResolutionFD_Exit
    End If
 
End Sub
'
'
'
'###############################'
'                               '
'          UTILISATION          '
'                               '
'###############################'
'
'Ecrire 'proResolution Me' dans la procédure VBA Form_Open du formulaire à redimensionner...
'
'Ecrire 'proResolutionFD Me' dans la procédure VBA Form_Open du formulaire feuille de données...
'
'Ecrire 'proResolutionFD_Exit Me.NomDuContrôleSousFormulaire.Form' dans la procédure VAB Form_Close
'du formulaire à redimensionner (celui contenant le(s) sous-formulaire(s) en feuille de données).
'A écrire autant de fois qu'il y a de sous-formulaires en feuille de données...
'
'Attention à bien dimensionner les colonnes au départ, sans aucun redimensionnement, et à prévoir une
'marge car l'ascenseur s'élargit lorsqu'on descend en résolution...

Le 20.07.2007 : Prise en charge des onglets et des boutons radios

Test effectués (Access 2003 et XP) : Boutons radios, cases à cocher, onglets avec plusieurs pages (contenant elles mêmes d'autres objets spéciaux), images, Calendrier ActiveX, et puis les contrôles standards : Boutons, listes, étiquettes...

Bogues constatés : Problème de redimensionnement des sections, colonnes des listes non redimensionnées...

Améliorations à venir :
+ Gestion de la largeur des colonnes des listes. Les listes se mettent aux bonnes dimensions, mais pas les colonnes. Elles restent fixent par rapport aux cm entrès lors de la conception...
+ Prise en charge complète des sections...

Le 21.07.2007 : Prise en charge des listes et des sections, simplification du code

Test effectués (Access 2003 et XP) : Tous les tests précédents ainsi que des tests avec différentes sections et différentes listes (fixes, déroulantes)

Le 26.07.2007 : Essai prise en charge des formulaires "feuille de données" + quelques 'tites modifs du code...

Nouveaux essais (Access 2003 et XP) : Concluants pour le 1er redimensionnement, mais les colonnes ne reprennent pas leurs dimensions originales...

Le 27.07.2007 : Prise en charge des formulaires "feuille de données"

Nouveaux essais concluants ! Petit bug constaté : Lorsqu'on change de résolution, il faut ouvrir deux fois le formulaire. La première fois, les colonnes sont invisibles, pourtant unr boite de message me certifie que celles-ci sont de largeur > 0... Je ne sais pas d'où ça vient...
Ceci dit, je pense qu'il faudrait pousser plus loin la recherche et affecter à chaque colonne, non pas une dimension, mais un pourcentage en fonction de la largeur (moins la largeur de l'ascenseur...).................

Tests à venir : Essais avec le RunTime...

Merci à tous pour vos conseils... et merci d'avance si vous souhaitez jeter un oeil à ce code et effectuer différents tests...

[Philippe JOCHMANS]

Bonjour

Il faudrait essayer de tester evec des composants non standard qui sont souvent utiliser sous Access (DtPicker, Calendrier, et...)

Starec

[seb92400]

Ok, je note...

Edit:
Pour le calendrier ActiveX, aucun problème... Il se redimensionne, j'ai juste corrigé au niveau du redimensionnement de la police (ce contrôle n'en ayant pas).

Je n'ai jamais utilisé le "dtPicker" par contre... je le trouve où ?

[seb92400]

Hello,

Je viens d'apporter quelques corrections à mon code de départ, notamment la gestion des onglets... J'ai également mis quelques annotations en plus...

PS : J'ai préféré corriger le code du début de mon premier messge afin qu'il n'y ait pas trop de codes ou trop de versions dans ce message... Si j'ai mal fait, n'hésitez pas à me corriger !!

Bonne journée à tous ! (euh... sous la pluie ici............)

[boulap]

Bonjour à tous !

Ce sujet a l'air super intéressant !

J'ai donc tester le code, je suis sous Access 97.
Sur un Form_open j'ai donc indiqué proResolution Me et là j'ai une erreur à l'ouverture du formulaire :
"Erreur de compilation, sub ou fonction non définie" sur

Else
        MsgBoxPlusErreur "modResolution", "proResolution", CStr(Err.Number), Err.Description
        Err.Clear
        Resume Sortie_proResolution
    End If

Par avance merci :-)

[seb92400]

Hello,

Oui, tout à fait, et c'est normal !!!

C'est une gestion d'erreur perso ! Remplace ce morceau de code par :

MsgBox Err.Number & " : " & Err.Description
Err.Clear
Resume Sortie_proResolution

Voilà...

Attenton à une chose : Je ne sais pas si c'est compatible avec des versions antérieures à Access 2003...

[boulap]

Merciiiiiiiiiiii :-)

Sauf que now j'ai une erreur Erreu de compilation, Etiquette non définie sur Resume Sortie_proResolution alors que j'ai bien plus loin

Sortie_proResolution:
    Exit Sub

Par avance merci ;-)
@+

[seb92400]

Hello,

Je ne connais pas Access 97. Mais comme de toute façon, il n'y a pas de code dans la section "sortie", tu n'as qu'à remplacer Resume Sortie_proresolution par Exit Sub.

Comme ça, pas besoin de faire un retour sur une section qui ne sert qu'à quitter la procédure...

[seb92400]

Hello,

Voilà... Je viens d'apporter une nouvelle modif à mon code... Cette fois-ci, les onglets, les listes, les contrôles, les sections, etc... sont normalement pris en compte... Si l'envie vous dit de tester tout ça... Je suis preneur des bogues à corriger !!!

Bon week-end à toutes et tous !!!

[Domi2]

Bonjour Noawsen,

Premières constatations.

Access XP, Windows XP pro. Pas de bugs, compile parfaitement.

Un formulaire développé en 800 x 600 (j'ai donc changé les constantes) affiché en 1024 x 768).

Ce formulaire est affiché sans barre d'état, mais avec une barre de menus personnalisée. Dimension "limite", puisqu'il fait 21cm de largeur, sur 13.5 de hauteur, sans bordure. Propriété auto centrer à Oui

L'affichage n'est pas tout à fait correct dans la mesure où il est mal positionné en haut à gauche (à vue d'oeil, je dirai 2cm trop à droite et 1.5cm trop bas). J'ai donc les barres de défilement verticale et horizontale, alors qu'il devrait occuper uniquement la quasi-totalité de l'écran.

Ton ratio de redimmensionnement est peut-être un "poil" trop généreux... Mais c'est peut-être aussi un peu trompeur. Comme il est trop grand, la propriété Auto centrer ne fait peut-être pas correctement son boulot !

Un contrôle un peu particulier, un treeview, se redimmensionne parfaitement.

Pour le reste de ce que je vois... Chapeau... C'est plus que prometteur...

Domi2

[seb92400]

Hello,

L'affichage n'est pas tout à fait correct dans la mesure où il est mal positionné en haut à gauche (à vue d'oeil, je dirai 2cm trop à droite et 1.5cm trop bas). J'ai donc les barres de défilement verticale et horizontale, alors qu'il devrait occuper uniquement la quasi-totalité de l'écran.

Effectivement... Perso, j'utilise une procédure de centrage que je place après le "proResolution Me"... et que j'ai appelé... "proCentrer Me" !! (Elle est dans les sources, il me semble... je ne crois pas l'avoir retouchée...)

Ton ratio de redimmensionnement est peut-être un "poil" trop généreux... Mais c'est peut-être aussi un peu trompeur. Comme il est trop grand, la propriété Auto centrer ne fait peut-être pas correctement son boulot !

Pour le facteur de redimensionnement, vu que tu pars d'une petite résolution et que tu montes, il n'est normalement pas nécessaire... Je l'ai prévu au cas où ce soit l'inverse (développé en 1024x768 et passé en 800x600). Je devrais peut-être changer la condition pour n'utiliser le facteur qu'en cas de résolution inférieure (pourtant, c'est bizarre, il me semble l'avoir déjà fait, et je suis revenu dessus)... A tester...
Ce ratio est donc là pour rendre les polices visibles quand on descend en résolution... A tester pour le diminuer au maximum...

Un contrôle un peu particulier, un treeview, se redimmensionne parfaitement.

Super J'avais pas testé !

Pour le reste de ce que je vois... Chapeau... C'est plus que prometteur...

Merci de ton aide, c'est très sympa !!! Je vais mijoter tout cela ce dimanche... J'aurais l'esprit plus frais lundi... et peut-être un peu moins mal à la gorge (dfyzefy ygfey fzyeff de temps !!!)

Bon week-end !!! Enfin... bon dimanche...