Récupération de la résolution de plusieurs écran

J

Jo_VBA

XLDnaute Nouveau
Bonjour à tous,

Cela fait un moment que je cherche sur le web un bout de code, solutions, explications pour pouvoir récupérer la résolution de plusieurs écran connecté à 1 PC sans résultat.

Actuellement j'utilise le code ci-dessous, récupéré sur le net et mit à ma sauce, qui me permet de connaitre le ratio et ainsi redimensionner mon interface à l'écran.

Par contre si l'utilisateur ouvre le fichier excel sur son écran secondaire et que celui-ci n'a pas le même ratio, l'interface est dimensionné pour l'écran principal ! Ce qui est mon cas, mon écran principal a une résolution 16/9 et mon écran secondaire une résolution 4/3.

Voici le code actuel :

Code: 
Option Explicit
Private Declare PtrSafe Function GetDC Lib "User32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "User32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
'
Private Const LOGPIXELSX = 88 'Pixels/inch in X
'
'A point is defined as 1/72 inches
Private Const POINTS_PER_INCH As Long = 72

Public Const SM_CXSCREEN = 0

Public Const SM_CYSCREEN = 1



Function Rez_Display()

    'This function determined the ratio of the MAIN display of the user's computer
    'Function result is equal at :
    '169 = 16/9 screen (i.e.1920x1080)
    '43   = 4/3 screen (i.e. 1024x768)
    '54   = 5/4 screen (i.e. 1280x1024)
    
    Dim LargeurVid As Long, HauteurVid As Long

    LargeurVid = GetSystemMetrics(SM_CXSCREEN)
    HauteurVid = GetSystemMetrics(SM_CYSCREEN)

    If LargeurVid / HauteurVid * 9 = 16 And HauteurVid / LargeurVid * 16 = 9 Then
        Rez_Display = 169
    ElseIf LargeurVid / HauteurVid * 3 = 4 And HauteurVid / LargeurVid * 4 = 3 Then
        Rez_Display = 43
    ElseIf LargeurVid / HauteurVid * 4 = 5 And HauteurVid / LargeurVid * 5 = 4 Then
        Rez_Display = 54
    Else
        Rez_Display = 169
    End If
End Function

Donc si quelqu'un sait comment récupérer la résolution de l'écran secondaire, c'est très volontier :)
 
Dernière modification par un modérateur:
Trier par date Trier par votes
P

PMO2

XLDnaute Accro
Re : Récupération de la résolution de plusieurs écran

Bonjour,

Si cela peut vous aider voici un code pour énumérer les différents écrans
Code: 
'### APIs déclarations pour 32 bits ###
Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" ( _
  ByVal hMonitor As Long, ByRef lpmi As MONITORINFOEX) As Long
Declare Function MonitorFromPoint Lib "user32.dll" ( _
  ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
Declare Function MonitorFromRect Lib "user32.dll" ( _
  ByRef lprc As RECT, ByVal dwFlags As Long) As Long
Declare Function MonitorFromWindow Lib "user32.dll" ( _
  ByVal hwnd As Long, ByVal dwFlags As Long) As Long
Declare Function EnumDisplayMonitors Lib "user32.dll" ( _
  ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
Declare Function GetWindowRect Lib "user32" ( _
  ByVal hwnd As Long, lpRect As RECT) As Long

'### Constantes et types (structures) ###
Const MONITORINFOF_PRIMARY = &H1
Const MONITOR_DEFAULTTONEAREST = &H2
Const CCHDEVICENAME = 32

Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Type MONITORINFOEX
  cbSize As Long
  rcMonitor As RECT
  rcWork As RECT
  dwFlags As Long
  szDevice As String * CCHDEVICENAME
End Type

'### Variable de portée module ###
Dim A$

Sub EnumEcrans()
A$ = ""
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
MsgBox A$
End Sub

Public Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, lprcMonitor As RECT, ByVal dwData As Long) As Long
Dim MI As MONITORINFOEX
Dim REC As RECT
'--- Structure MONITORINFO ---
MI.cbSize = Len(MI)
GetMonitorInfo hMonitor, MI
'--- Obtention des infos ---
A$ = A$ & "Moniteur Handle : " & CStr(hMonitor) & vbLf
'---
A$ = A$ & "Moniteur nom : " & Mid(MI.szDevice, 1, InStr(1, MI.szDevice, Chr(0)) - 1) & vbLf
'---
With MI.rcMonitor
  A$ = A$ & "Moniteur Width/Height : " + CStr(.Right - .Left) + "x" + CStr(.Bottom - .Top) & vbLf
End With
'---
With MI.rcWork
  A$ = A$ & "Moniteur Width/Height (surface de travail) : " + CStr(.Right - .Left) + "x" + CStr(.Bottom - .Top) & vbLf
End With
'---
A$ = A$ & "Moniteur principal : " + CStr(CBool(MI.dwFlags = MONITORINFOF_PRIMARY)) & vbLf
'---
If MonitorFromWindow(Application.hwnd, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "Excel apparaît sur ce moniteur" & vbLf
End If
'---
If MonitorFromPoint(0, 0, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "Le point ( 0 , 0 ) se trouve dans la portée de ce moniteur" & vbLf
End If
'---
GetWindowRect Application.hwnd, REC
If MonitorFromRect(REC, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "La fenêtre Excel se trouve dans ce moniteur" & vbLf
End If
'---
A$ = A$ & vbLf
'--- Suite de l'énumération ---
MonitorEnumProc = 1
End Function

A NOTER :
1) Je ne possède qu'un seul écran et je n'ai pas pu tester si cela fonctionne avec plusieurs.
2) Je suis en 32 bits et il faudra adapter les déclarations APIs et les structures qui sont employées au 64 bits.
 
Vote positif 0 Vote négatif
D

david84

XLDnaute Barbatruc
Re : Récupération de la résolution de plusieurs écran

Bonjour,
Je suis en 32 bits et il faudra adapter les déclarations APIs et les structures qui sont employées au 64 bits
Cliquez pour agrandir...

Code: 
#If Win64 Then  
  Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" ( _
    ByVal hMonitor As Long, ByRef lpmi As MONITORINFOEX) As Long
    
  Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" ( _
    ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
    
  Declare PtrSafe Function MonitorFromRect Lib "user32.dll" ( _
    ByRef lprc As RECT, ByVal dwFlags As Long) As Long
    
  Declare PtrSafe Function MonitorFromWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, ByVal dwFlags As Long) As Long
    
  Declare PtrSafe Function EnumDisplayMonitors Lib "user32.dll" ( _
    ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As Long) As Long
    
  Declare PtrSafe Function GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, lpRect As RECT) As Long
#Else
  Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" ( _
    ByVal hMonitor As Long, ByRef lpmi As MONITORINFOEX) As Long
    
  Declare Function MonitorFromPoint Lib "user32.dll" ( _
    ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
    
  Declare Function MonitorFromRect Lib "user32.dll" ( _
    ByRef lprc As RECT, ByVal dwFlags As Long) As Long
    
  Declare Function MonitorFromWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, ByVal dwFlags As Long) As Long
    
  Declare Function EnumDisplayMonitors Lib "user32.dll" ( _
    ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
    
  Declare Function GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, lpRect As RECT) As Long
#End If
NB : il convient d'être attentif à la déclaration des variables des fonctions d'énumération employées en 64 bits
A+
 
Vote positif 0 Vote négatif
J

Jo_VBA

XLDnaute Nouveau
Re : Récupération de la résolution de plusieurs écran

Hello,

J'ai testé sur mon post et en modifiant comme l'a proposé david84 j'ai bien récupérer les informations des 2 écrans.
2015-10-21_115633.png

C'est simplement plus que je ne penssais, maintenant je dois réfléchir comment je vais utiliser cette fonction :D

Dernière question, si je déclare mes fonctions qui tape dans les dll "Ptrsafe", est-ce que ça va planter sur un post 32bits ?

J'ai testé la solution à david84 de mettre "if Win64..." mais la partie "else" est rouge, vba n'accepte pas :(

Merci en tout cas à vous PMO2 et david84 pour votre aide.
Je vais tâcher de comprendre un peu mieux le code de mon côté car c'est au dessus de mes compétences actuels pour comprendre comment ça fonctionne !
 
Vote positif 0 Vote négatif
D

david84

XLDnaute Barbatruc
Re : Récupération de la résolution de plusieurs écran

Bonjour,
C'est simplement plus que je ne penssais, maintenant je dois réfléchir comment je vais utiliser cette fonction
Cliquez pour agrandir...
Si tu n'as pas besoin de toutes les informations récupérés par le code proposé par PMO2 ne prends que ce qui te sert.
Dernière question, si je déclare mes fonctions qui tape dans les dll "Ptrsafe", est-ce que ça va planter sur un post 32bits ?
Cliquez pour agrandir...
Le code est fait pour fonctionner aussi bien sur un poste 32 ou 64 bits.
J'ai testé la solution à david84 de mettre "if Win64..." mais la partie "else" est rouge, vba n'accepte pas
Cliquez pour agrandir...
Cela est le cas la 1ère fois lorsque tu recopies le code mais après c'est bon normalement.
Attention ne pas oublier le # devant les conditions :

#If Win64 Then

#Else

#End If

tu as testé sur un ordinateur 32 ou 64 bits ?

A+
 
Vote positif 0 Vote négatif
J

Jo_VBA

XLDnaute Nouveau
Re : Récupération de la résolution de plusieurs écran

david84 à dit:
Bonjour,

Si tu n'as pas besoin de toutes les informations récupérés par le code proposé par PMO2 ne prends que ce qui te sert.
Le code est fait pour fonctionner aussi bien sur un poste 32 ou 64 bits.

Cela est le cas la 1ère fois lorsque tu recopies le code mais après c'est bon normalement.
Attention ne pas oublier le # devant les conditions :

#If Win64 Then

#Else

#End If

tu as testé sur un ordinateur 32 ou 64 bits ?

A+
Cliquez pour agrandir...

Donc si je comprend bien, si je laisse les fonctions ptrsafe, ça marche sur 32 et 64bits ?
Car j'ai testé sur un poste 32bits et effectiement ça fonctionne, donc pas besoin de mettre le "#if Win64..."
 
Vote positif 0 Vote négatif
D

david84

XLDnaute Barbatruc
Re : Récupération de la résolution de plusieurs écran

Non : si tu ne travailles que sur une version d'Excel 32 bits le code initial de PMO2 suffit.
si tu ne travailles que sur Excel 64 bits la partie de mon code placée entre #If Win64 et #Else suffit.
Si ton programme est amené à tourner sur des versions d'Excel 32 et 64 bits : déclarer les fonctions API comme dans mon message 4.
Quand je parle de 32 ou 64 bits je parle de la version Excel installée sur ton ordinateur, pas de la version de ton système d'exploitation.
A+
 
Vote positif 0 Vote négatif
J

Jo_VBA

XLDnaute Nouveau
Re : Récupération de la résolution de plusieurs écran

david84 à dit:
Quand je parle de 32 ou 64 bits je parle de la version Excel installée sur ton ordinateur, pas de la version de ton système d'exploitation.
A+
Cliquez pour agrandir...

Alors je te confirme que mon test c'est porté sur une version 64bits d'excel (mon poste) et 32bits d'excel sur un autre poste.

D'où mon étonnement que les fonctions ne plantes pas sur le poste 32bits...
 
Vote positif 0 Vote négatif
J

Jo_VBA

XLDnaute Nouveau
Re : Récupération de la résolution de plusieurs écran

Il sagit du code de PMO2 mais en version 64bits.

Le code ci-dessous est seul dans un module.

Et je peux justement le démarrer le sub sur un Excel 32 ou 64 bits sans problème.

Code: 
'### APIs déclarations pour 64 bits ###
Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MONITORINFOEX) As Long
Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
Declare PtrSafe Function MonitorFromRect Lib "user32.dll" (ByRef lprc As RECT, ByVal dwFlags As Long) As Long
Declare PtrSafe Function MonitorFromWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal dwFlags As Long) As Long
Declare PtrSafe Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

'### Constantes et types (structures) ###
Const MONITORINFOF_PRIMARY = &H1
Const MONITOR_DEFAULTTONEAREST = &H2
Const CCHDEVICENAME = 32

Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Type MONITORINFOEX
  cbSize As Long
  rcMonitor As RECT
  rcWork As RECT
  dwFlags As Long
  szDevice As String * CCHDEVICENAME
End Type

'### Variable de portée module ###
Dim A$

Sub EnumEcrans()
A$ = ""
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
MsgBox A$
End Sub

Public Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, lprcMonitor As RECT, ByVal dwData As Long) As Long
Dim MI As MONITORINFOEX
Dim REC As RECT
'--- Structure MONITORINFO ---
MI.cbSize = Len(MI)
GetMonitorInfo hMonitor, MI
'--- Obtention des infos ---
A$ = A$ & "Moniteur Handle : " & CStr(hMonitor) & vbLf
'---
A$ = A$ & "Moniteur nom : " & Mid(MI.szDevice, 1, InStr(1, MI.szDevice, Chr(0)) - 1) & vbLf
'---
With MI.rcMonitor
  A$ = A$ & "Moniteur Width/Height : " + CStr(.Right - .Left) + "x" + CStr(.Bottom - .Top) & vbLf
End With
'---
With MI.rcWork
  A$ = A$ & "Moniteur Width/Height (surface de travail) : " + CStr(.Right - .Left) + "x" + CStr(.Bottom - .Top) & vbLf
End With
'---
A$ = A$ & "Moniteur principal : " + CStr(CBool(MI.dwFlags = MONITORINFOF_PRIMARY)) & vbLf
'---
If MonitorFromWindow(Application.hwnd, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "Excel apparaît sur ce moniteur" & vbLf
End If
'---
If MonitorFromPoint(0, 0, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "Le point ( 0 , 0 ) se trouve dans la portée de ce moniteur" & vbLf
End If
'---
GetWindowRect Application.hwnd, REC
If MonitorFromRect(REC, MONITOR_DEFAULTTONEAREST) = hMonitor Then
  A$ = A$ & "La fenêtre Excel se trouve dans ce moniteur" & vbLf
End If
'---
A$ = A$ & vbLf
'--- Suite de l'énumération ---
MonitorEnumProc = 1
End Function
 
Vote positif 0 Vote négatif
D

david84

XLDnaute Barbatruc
Re : Récupération de la résolution de plusieurs écran

Je viens de tester par acquis de conscience sur un Excel 32 bits et ce code ne fonctionne pas.
Ne confonds-tu pas la version Bit de ton système d'exploitation avec la version Bit du pack Office (dont Excel) installé sur l'ordinateur ?
A+
 
Vote positif 0 Vote négatif
J

Jo_VBA

XLDnaute Nouveau
Re : Récupération de la résolution de plusieurs écran

david84 à dit:
Donc c'est bien une version 64 bits d'Excel : c'est donc normal que le code du message 11 fonctionne. Par contre il ne fonctionnera pas tel quel sur une version 32 bits.
A+
Cliquez pour agrandir...
Il y a 2 screenshots ;) Et j'ai déjà testé sur les machines où j'ai prit les screenshots, donc ça marche sur les 2 versions.
Pourquoi, c'est une autre question...
 
Vote positif 0 Vote négatif

Discussions similaires

patricktoulon
  • Résolu(e)
XL 2013 prise de tête avec une variable static
Réponses
3
Affichages
236
patricktoulon
patricktoulon
V
  • Question
XL 2021 Upload fichier depuis Bureau
Réponses
7
Affichages
257
vmax67
V
R1-
  • Question
XL 2016 Impossible de SendKeys une tabulation
Réponses
4
Affichages
439
R1-
R1-
PHV.FSM
  • Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicos
Nicos
C
  • Question
XL 2019 Probleme olepro32 et/ou LongPtr
Réponses
11
Affichages
403
patricktoulon
patricktoulon
M
  • Question
XL 2016 Impression d'un rapport PDF depuis une URL avec VBA
Réponses
3
Affichages
544
mrcooll
M
youky(BJ)
  • Question
Microsoft 365 lire .wav en 32 ou 64bits VBA
Réponses
7
Affichages
617
matlatarte
M
GADENSEB
  • Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
476
GADENSEB
GADENSEB
patricktoulon
  • Résolu(e)
XL 2013 icon avec une image Mso dans la barre de titre du UserForm
Réponses
10
Affichages
785
patricktoulon
patricktoulon
F
  • Question
Microsoft 365 UserForm maximiser la taille du formulaire par rapport à la taille de l'écran
2
Réponses
22
Affichages
2 K
TooFatBoy
TooFatBoy

Membres actuellement en ligne

14 membres et 189 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 286
Messages
2 086 795
Membres
103 392
dernier inscrit
doc_banane