XL 2016 VBA - Positionnement UserForm - PC a 2 écrans

[Dudu2]

Bonjour,

J'ai fait un code pour un utilisateur qui possède 2 écrans sur son PC. Je n'ai pas cette config.
Lorsqu'il lance ce UserForm, il ne va pas sur la fenêtre Excel (1er écran à gauche) mais sur le Bureau (2ème écran à droite).

Une idée de comment forcer le UserForm à s'afficher dans l'écran de la fenêtre Excel ?
Merci par avance.

 

[patricktoulon]

re ben en fait je crois que ca dépends du quel est l’écran 1 et le 2
apres tu peux redresser en enlevant au left la largeur de l’écran ( en point hein!!!) et il va se retrouver en écran gauche a condition que ce soit bien le gauche qui est le 1

 

[patricktoulon]

je me suis permis de rajeunir un peu ces codes api a rallonge

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
 
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long

#Else

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
#End If

Sub RemoveTitleBar()
    Dim mhWndForm As Long
    mhWndForm = FindWindow(vbNullString, Me.Caption)
    SetWindowLong mhWndForm, -16, &H94080080
    DrawMenuBar mhWndForm
End Sub

 

[Dudu2]

Salut @patricktoulon,
Tu veux dire que l'écran 2 commence en points là où finit l'écran 1 ?
Merci pour le lifting du Caption. Avec tes ExecuteExcel4Macro ça donne quoi ?

 

[patricktoulon]

tu le veux en macro4 aussi ?

 

[Dudu2]

Si tu l'as... Why not ?

 

[Compte Supprimé 979]

Bonsoir Messieurs,

Voici perso ce que j'utilise
Dans l'USF

Private Sub UserForm_Initialize()
  ' Préparer l'USF à s'afficher sur l'écran principal
  Set ExtDis = New ExtendedDisplay  ' Définir la classe
  Set ExtDis.frmPairedForm = Me
  ' Afficher l'USF sur le 1er écran
  ExtDis.CenterFormOnPrimaryScreen
End Sub

Dans un module de classe nommé "ExtendedDisplay"

Option Explicit

'Function to get screen resolution
' This object is used to return positioning information on a sytem with one extended display.
' My primary screen is the left one, I have not tried it with another set up.
'Notes
'x = 0   'This is width of primary display
'x = 1   'This is height of primary display
'x = 78  'Total width of both displays
'ValueYouWant = GetSystemMetrics(x)
#If Win64 Then
  Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
#Else
  Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
#End If

'Functions to get DPI
' Constante Win64 qui vaut True uniquement si Office est installé en 64 bits.
#If Win64 Then
  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
#Else
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
#End If
Private Const LOGPIXELSX = 88  'Pixels/inch in X
Private Const POINTS_PER_INCH As Long = 72  'A point is defined as 1/72 inches

Private blnMainScreen As Boolean
Private blnMultipleScreens As Boolean
Private blnSetUp As Boolean  'True after being set up
Public frmPairedForm As Object

'Return DPI
Private Function PointsPerPixel() As Double
  Dim hDC As Long
  Dim lDotsPerInch As Long
 
  hDC = GetDC(0)
  lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
  PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
  ReleaseDC 0, hDC
End Function

'Return the right position of extended display
Public Sub CenterFormOnSecondaryScreen()
  Dim dblScreen1Width As Double                               'Primary display width
  Dim dblTotalWidth As Double                             'Total width of both screens
  Dim dblScreen2Left As Double                              'Left of second screen
 
  Me.SetUp
  dblScreen1Width = GetSystemMetrics32(0) * PointsPerPixel    'Get it
  dblTotalWidth = GetSystemMetrics32(78) * PointsPerPixel     'Get it
  dblScreen2Left = dblTotalWidth - dblScreen1Width            'Get middle of displays
  frmPairedForm.Left = ((dblScreen2Left) + ((dblTotalWidth - dblScreen2Left) / 2)) - (frmPairedForm.Width / 2)
End Sub

'Position the passed user form reference in center screen of primary display
Public Sub CenterFormOnPrimaryScreen()
  Dim dblScreen1Width As Double                                       'Primary display width
  Dim dblTotalWidth As Double                                     'Total width of both screens
  Dim dblScreen2Left As Double
  Me.SetUp
 
  dblScreen1Width = GetSystemMetrics32(0) * PointsPerPixel            'Get it
  dblTotalWidth = GetSystemMetrics32(78) * PointsPerPixel             'Get it
  dblScreen2Left = dblTotalWidth - dblScreen1Width                    'Get middle of displays
  frmPairedForm.Left = (dblScreen2Left / 2) - (frmPairedForm.Width / 2)
End Sub

'Figure out whether or not to make changes based on if the user has multiple screens or not
Public Sub SetUp()
  Dim dblScreen1Width As Double                               'For width of main screen
  Dim dblTotalWidth As Double
 
  dblTotalWidth = GetSystemMetrics32(78) * PointsPerPixel     'Get it
  dblScreen1Width = GetSystemMetrics32(0) * PointsPerPixel    'Get it
 
  If Not dblScreen1Width = dblTotalWidth Then                 'If primary display width <> total width then
    blnMultipleScreens = True                               'You have multiple displays
  Else
    blnMultipleScreens = False                              'You do not have multiple displays
  End If
 
  If frmPairedForm.Left < dblScreen1Width Then                'If form start up left pos is on the primary display then
    blnMainScreen = True                                    'Userform is on the main screen
  Else
    blnMainScreen = False
  End If
End Sub

'If on the main screen, and there are multiple displays, move to secondary. Vice Versa
Public Sub SwapScreens()
  Me.SetUp                                'If this hasn't been set up yet, then do it
  If blnMultipleScreens Then              'Only continue if the user has multiple screens
    If blnMainScreen Then               'If on primary display
      Me.CenterFormOnSecondaryScreen  'Move to secondary
      Else                                'Else
        Me.CenterFormOnPrimaryScreen    'Move to primary
      End If
    End If
End Sub

A+

 

[patricktoulon]

salut bruno

@Dudu2
tu peux virer les déclarations avec ça

Sub RemoveTitleBar()
 Dim mhWndForm, h
    h = Me.InsideHeight
    mhWndForm = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")        'handle fenetre active
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & mhWndForm & ", " & -16 & ", " & &H94080080 & ")")      'api SetWindowLongA
    ExecuteExcel4Macro ("CALL(""user32"",""DrawMenuBar"",""JJJJJJ"", " & mhWndForm & ")")
Me.Height = h + 4
End Sub

 

[Dudu2]

Merci @BrunoM45,
Je vais regarder ça attentivement.

Ce problème semble partagé sur pas mal de forum sans réponse claire.
Et si j'utilisais Application.Left & Top au lieu d'utiliser ActiveWindow.Left & Top ?

@patricktoulon,
Merci pour les ExecuteExcel4Macro.

 

[patricktoulon]

ben si tu le veux exactement en bas a gauche(DE L'APPLICATION !!!) (c'est comme ca que ca tombe chez moi) oui
si tu le veux en bas a gauche de l’écran au dessus de la taskbars non

 

[patricktoulon]

on peut l'attacher à l'application si tu veux

 

[Dudu2]

Je le veux là où se trouve affichée la feuille Excel. Et le positionner par rapport à la feuille Excel.

 

[patricktoulon]

alors tu va changer la sub de caption pour celle ci

Sub RemoveTitleBar()
    Dim mhWndForm, h
    h = Me.InsideHeight
    mhWndForm = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")        'handle fenetre active
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & mhWndForm & ", " & -16 & ", " & &H94080080 & ")")      'api SetWindowLongA
    ExecuteExcel4Macro ("CALL(""user32"",""DrawMenuBar"",""JJJJJJ"", " & mhWndForm & ")")
    ExecuteExcel4Macro ("CALL(""user32"",""SetParent"",""JJJJJ""," & mhWndForm & ", " & Application.hwnd & ")")
    Me.Height = h
End Sub

dorenavant le userform n'est plus enfant du desktop mais de l'application
dans le activate
on la place en bas a droite de l'application

Private Sub UserForm_Activate()
    Call RemoveTitleBar
    Me.Move 0, Application.Height - Me.Height
    Me.TextBox_StatusBar = "Test de message sur UserForm en zone Status Bar"
End Sub

dans le thisworkbook
on la remet en place a chaque fois que tu resize l'application

Private Sub Workbook_WindowResize(ByVal Wn As Window)
UserForm_StatusBar.Move 0, Application.Height - UserForm_StatusBar.Height
End Sub

et voila

 

[Dudu2]

Purée ! Tu fais des trucs de ouf !
J'en perds mon latin. Mais j'ai compris la manip.

 

[patricktoulon]