XL 2019 Adaptation d'une interface à la résolution de plusieurs écrans

loic74* · 10 Mai 2021

Bonjour à tous,

Je suis en train de créer une interface servant de menu pour gérer des dossier et je souhaitais faire en sorte que l'application s'adapte aux différentes résolutions des utilisateurs lorsque ceux-ci utilisent plusieurs écran pouvant avoir des résolutions différentes.
Pour cela, j'ai trouvé une fonction qui me permet d'ajuster la taille de l'interface à l'écran de l'utilisateur en changeant la résolution grâce au code suivant :

Option Explicit
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type

Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" _
(ByVal hWnd As Long, rectangle As RECT) As Long

Function GetScreenResolution() As String
Dim R As RECT
Dim hWnd As Long
Dim RetVal As Long
hWnd = GetDesktopWindow()
RetVal = GetWindowRect(hWnd, R)
GetScreenResolution = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
End Function

Puis je passe pour un bouton dynamique qui me permet d'appliquer cette fonction et d'ajuster la résolution :

Private Sub CommandButton1_Click()
Dim Hauteur As Variant, Zoom As Double, Resolution As String
Const Zoom_100 As Integer = 1368

Resolution = GetScreenResolution
Hauteur = Mid(Resolution, 1, InStrRev(Resolution, "x") - 1)
Zoom = (100 / Zoom_100) * CDbl(Hauteur)

MsgBox "Résolution actuelle : " & Resolution & " zoom passé à : " & Format(Zoom, "0") & " % (100% = " & Zoom_100 & ")"

ActiveWindow.Zoom = Format(Zoom, "0")
End Sub

Mon problème est que si l'utilisateur travail sur plusieurs écrans simultanément, l'interface ne modifie pas le zoom et ne prend en compte que la résolution de l'écran défini comme écran principal.
Je me demande donc s'il est possible d'ajuster l'interface, soit à l'aide du bouton ou automatiquement, en fonction des différentes résolutions de l'utilisateur (autre que l'écran principal) ?

D'avance merci pour votre aide !

Lolote83 · 10 Mai 2021

Bonjour LOIC74*,
Va faire un tour sur ce fil, cela permet d’identifier les écrans et ainsi tu devrais y retrouver tes petits
https://www.excel-downloads.com/threads/recuperation-de-la-resolution-de-plusieurs-ecran.20001925/
Je viens de faire un test et chez moi, les deux écrans sont bien détectés
Excel lancé sur écran principal

Bon courage
@+ Lolote83

job75 · 10 Mai 2021

Bonjour loic74*, bienvenue sur XLD,

Le titre de la discussion n'est pas du tout significatif, modifiez-le.

Et joignez votre fichier, allégé et sans données confidentielles.

Cela dit je n'irai pas plus loin car je ne travaille pas sur plusieurs écrans

Edit : salut Lolote83, pas rafraîchi.

A+

Usine à gaz · 10 Mai 2021

Bonjour loic74*, Lolote83, Gérard, le Forum,

@ loic74* : peut-être comme ça

Sheets("SOMMAIRE").Select
Range(Cells(1, 24), Cells(1, 1)).Select
ActiveWindow.Zoom = True 'ActiveWindow.Zoom = 114

voir fichier en retour,
Amicalement,
lionel,

Lolote83 · 10 Mai 2021

Bonjour Usine à gaz.
Effectivement ça peut le faire et c'est très court .....
@+ Lolote83

cathodique · 10 Mai 2021

Usine à gaz à dit:
Bonjour loic74*, Lolote83, Gérard, le Forum,

@ loic74* : peut-être comme ça

Sheets("SOMMAIRE").Select
Range(Cells(1, 24), Cells(1, 1)).Select
ActiveWindow.Zoom = True 'ActiveWindow.Zoom = 114

voir fichier en retour,
Amicalement,
lionel,

Bonjour Usine à gaz , Lolote83 , job75 ,loic74* ,

@Usine à gaz : juste pour info, chez-moi sous Excel 2010 le code plante sur la ligne ci-dessous de la procédure WorkBook_Open

VB:

    ActiveWindow.EnableResize = False

Usine à gaz · 10 Mai 2021

Bonsoir cathodique

Chez moi ça ne plante pas c'est curieux que ça plante chez toi.

VB:

Private Sub Workbook_Open()
    Application.CommandBars(1).Enabled = False
    ActiveWindow.EnableResize = False
    Application.DisplayFormulaBar = False
    ActiveWindow.DisplayHorizontalScrollBar = False
    ActiveWindow.DisplayVerticalScrollBar = False
    ActiveWindow.DisplayWorkbookTabs = False
    ActiveWindow.DisplayHeadings = False
    Application.DisplayFullScreen = True

Dim CmdB As CommandBar
For Each CmdB In Application.CommandBars
CmdB.Enabled = False
Next CmdB

Worksheets("SOMMAIRE").ScrollArea = "a1:D10"
Sheets("SOMMAIRE").Select
Range(Cells(1, 24), Cells(1, 1)).Select
    ActiveWindow.Zoom = True

End Sub

Je testerai encore,
lionel

cathodique · 10 Mai 2021

Usine à gaz à dit:

Bonsoir cathodique

Chez moi ça ne plante pas c'est curieux que ça plante chez toi.

VB:

Private Sub Workbook_Open()
    Application.CommandBars(1).Enabled = False
    ActiveWindow.EnableResize = False
    Application.DisplayFormulaBar = False
    ActiveWindow.DisplayHorizontalScrollBar = False
    ActiveWindow.DisplayVerticalScrollBar = False
    ActiveWindow.DisplayWorkbookTabs = False
    ActiveWindow.DisplayHeadings = False
    Application.DisplayFullScreen = True

Dim CmdB As CommandBar
For Each CmdB In Application.CommandBars
CmdB.Enabled = False
Next CmdB

Worksheets("SOMMAIRE").ScrollArea = "a1:D10"
Sheets("SOMMAIRE").Select
Range(Cells(1, 24), Cells(1, 1)).Select
    ActiveWindow.Zoom = True

End Sub

Je testerai encore,
lionel

Merci pour ton retour. Est-ce que tu es sous Excel 2010 32bits/ Win7 6 bits?

Usine à gaz · 10 Mai 2021

Je suis sous windoww10 64 et
Setup.X64.fr-fr_O365BusinessRetail_028b3ef4-42f1-409d-901b-d8c0f8ee9f17_TX_DB_b_32_
donc excel 64 bytes

cathodique · 10 Mai 2021

Usine à gaz à dit:
Je suis sous windoww10 64 et Office 365

Merci. Excel 2010 patine.

patricktoulon · 10 Mai 2021

bonjour
pour info
zoom n'accepte q'un long de 1 à 400 ou un boolean(false/true)
tu capte la résolution c'est en pixel hors on travaille en point sur excel
bref c'est tout faux de A à Z

patricktoulon · 10 Mai 2021

re
vire ton module 1 a la poubelle
dans le module de la feuille en question
clique pour plein ecran sans le ruban et reclique pour le remettre normal

VB:

Option Explicit
Dim z As Boolean
Dim Wstate As Long
Private Sub CommandButton1_Click()
    If Not z Then
        z = True
        Wstate = Application.WindowState
        ExecuteExcel4Macro "Show.Toolbar(""Ribbon"",false)"  
        Application.WindowState = xlMaximized
        [A1:X46].Select
        ActiveWindow.Zoom = z
    Else
        Application.WindowState = Wstate
        ExecuteExcel4Macro "Show.Toolbar(""Ribbon"",True)"   
        ActiveWindow.Zoom = 100
    z = False
    End If
End Sub

et voila c'est pas compliqué
si tu est en double écran (en mode étendu) c'est a dire le bureau sur les deux écran)ça ne peut pas fonctionner
sinon normalement l'application se met en plein écran sur l’écran principal toute seule
c'a n'est pas forcé l'ecran 1 soit le principal voir dans ta config paramètres d'affichage
il faut etre en double ecran 1 et 2 mode double

loic74* · 11 Mai 2021

Bonjour à tous,
Merci pour votre aide, je vais tester tous ça pour voir si ça fonctionne chez moi

loic74* · 11 Mai 2021

@patricktoulon super ça fonctionne super bien !
Il y t'il un moyen pour que la fonction se lance automatiquement ou il faut obligatoirement passer par un bouton de commande ?
Merci pour votre aide à tous !

patricktoulon · 11 Mai 2021

bonjour ben tu la lance dans le workbook_open c'est tout
vire le code que je t'ai donné dans la feuille et met celui ci dans le module thisworkbook

VB:

Option Explicit
Private Sub Workbook_Open()
    fullscreen
End Sub
Sub fullscreen()
    With Application
       .WindowState = xlMaximized
        .DisplayFormulaBar = False
        .DisplayScrollBars = False
        .ExecuteExcel4Macro "Show.Toolbar(""Ribbon"",false)"
         [A1:X46].Select
    End With
    With ActiveWindow
        .Zoom = True
        .DisplayWorkbookTabs = False
        .DisplayHeadings = False
    End With
End Sub

et voila

XL 2019 Adaptation d'une interface à la résolution de plusieurs écrans

loic74*

XLDnaute Nouveau

Pièces jointes

Lolote83

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Pièces jointes

Lolote83

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

loic74*

XLDnaute Nouveau

loic74*

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

Discussions similaires