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

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

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

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

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

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

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

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