XL 2016 VBA - Alternative à AddressOf dans un module de classe / UserForm

Option Explicit


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

Private Type MONITORINFO: cbSize As Long: rcMonitor As RECT: rcWork As RECT: dwFlags As Long: End Type

Private Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, ByRef lpmi As MONITORINFO) As Long

Private Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long, ByVal dwFlags As LongPtr) As LongPtr

Private Declare PtrSafe Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal dwFlags As Long) As LongPtr
Sub test()
'coté:=0    =l'ecran gauche si 2 ecran ou ecran si un seul ecran
'coté:=1    =l'ecran  droite si 2 ecran ou ecran si un seul ecran
'coté:=2    ='lécran ou se trouve la fenêtre excel
'coté omis  =gauche par defaut ou ecran  si un seul ecran
afficheUserform UserForm1, coté:=2
End Sub
Sub afficheUserform(usf, Optional coté As Long = 0)   'centre ecran gauche ou centre de l'ecran par defaut si un seul ecran
    Dim MI_G As MONITORINFO, Mx, My, MG, MExcel, gauche#, LtoP, fois&, PtPx#
   
    Mx = MonitorFromPoint(100, 100, &H2)    '&H2=MONITOR_DEFAULTTONEAREST 'l'ecran a 100 de droite du point (0,0)
   
    My = MonitorFromPoint(-100, -100, &H2)    '&H2=MONITOR_DEFAULTTONEAREST'l'ecran a -100 de gauche du point (0,0)
   
    MExcel = MonitorFromWindow(Application.hWnd, &H1) ' l'ecran ou se trouve l'application excel
   
     MG = Mx: fois = 1
   
    If Val(My) <> Val(Mx) Then MG = My: fois = -1
   
    If coté = 1 Then fois = Abs(fois)
   
    If coté = 2 Then MG = MExcel: fois = 1
   
    PtPx = 0.75    ' que saint DUDU me pardonne j'en ai ras le bol de ce ptpx :):):)
   
    MI_G.cbSize = Len(MI_G): GetMonitorInfo MG, MI_G

   
    gauche = (((MI_G.rcMonitor.Right * 0.75) - (UserForm1.Width)) / 2) * fois
   
    LtoP = (((MI_G.rcMonitor.Bottom * 0.75) - (UserForm1.Height)) / 2) * fois
   
    With usf
        .Show 0
        .Move gauche, LtoP
    End With
End Sub

With MonitorInformation
    UserForm1.StartUpPosition = 0
    UserForm1.Left = .rcMonitor.Left * PxToPt + ((.rcMonitor.Right - .rcMonitor.Left) * PxToPt - UserForm1.Width) / 2
    UserForm1.Top = .rcMonitor.Top * PxToPt + ((.rcMonitor.Bottom - .rcMonitor.Top) * PxToPt - UserForm1.Height) / 2
End With

Option Explicit

Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type
Private Type MONITORINFO: cbSize As Long: rcMonitor As RECT: rcWork As RECT: dwFlags As Long: End Type
Private Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal X As Long, ByVal Y As Long, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, ByRef MI As MONITORINFO) As Long
Private Const MONITOR_DEFAULTTONULL As Long = 0
Private Const MONITOR_DEFAULTTONEAREST As Long = 2

'--------------------
'Le UserForm baladeur
'--------------------
Sub TestUserForm()
    Dim TabMIs() As MONITORINFO
    Dim i As Integer
    '
    Const PxToPt = 0.6
    'Const PxToPt = 0.75
    Const Moniteur = "Gauche"
    'Const Moniteur = "Milieu"
    'Const Moniteur = "Droit"
 
    TabMIs = GetAllMonitorInfo
 
    Select Case Moniteur
        Case "Gauche"
            i = 1
        Case "Milieu"
            i = Int((UBound(TabMIs) + 1) / 2)
        Case "Droit"
            i = UBound(TabMIs)
    End Select
 
    With TabMIs(i)
        UserForm1.StartUpPosition = 0
        UserForm1.Left = .rcMonitor.Left * PxToPt + ((.rcMonitor.Right - .rcMonitor.Left) * PxToPt - UserForm1.Width) / 2
        UserForm1.Top = .rcMonitor.Top * PxToPt + ((.rcMonitor.Bottom - .rcMonitor.Top) * PxToPt - UserForm1.Height) / 2
        'UserForm1.Label1.Caption = "Moniteur " & Moniteur
        UserForm1.Show vbModeless
    End With
End Sub

'---------------------------
'Get all Monitor Information
'---------------------------
Function GetAllMonitorInfo() As MONITORINFO()
    Dim MI As MONITORINFO
    Dim TabMIs() As MONITORINFO
    Dim NbMIs As Integer
    Dim X As Long
    Dim Y As Long
    Dim hMonitor As LongPtr
    Dim PreviousLeft As Long
 
    'Look for monitors on the right of the primary monitor
    X = -10 ^ 6
    Y = 1
    PreviousLeft = -1
 
    Do While 1
        hMonitor = MonitorFromPoint(X, Y, MONITOR_DEFAULTTONEAREST)
        MI.cbSize = Len(MI)
        Call GetMonitorInfo(hMonitor, MI)
        With MI.rcMonitor
            If .Left = PreviousLeft Then Exit Do
            NbMIs = NbMIs + 1
            ReDim Preserve TabMIs(1 To NbMIs)
            TabMIs(NbMIs) = MI
            PreviousLeft = .Left
            X = .Left + .Right
        End With
    Loop
 
    'Return value
    GetAllMonitorInfo = TabMIs
End Function

Private Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal X As Long, ByVal Y As Long, ByVal dwFlags As Long) As LongPtr

Private Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal pt As LongLong, ByVal dwFlags As Long) As LongPtr