Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Enum DWMWINDOWATTRIBUTE
DWMWA_NCRENDERING_ENABLED = 1
DWMWA_NCRENDERING_POLICY
DWMWA_TRANSITIONS_FORCEDISABLED
DWMWA_ALLOW_NCPAINT
DWMWA_CAPTION_BUTTON_BOUNDS
DWMWA_NONCLIENT_RTL_LAYOUT
DWMWA_FORCE_ICONIC_REPRESENTATION
DWMWA_FLIP3D_POLICY
DWMWA_EXTENDED_FRAME_BOUNDS
DWMWA_LAST
End Enum
Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type
Function GetUserFormExtendedFrameRECT() As RECT
Dim R As RECT, handle As LongPtr
handle = GetActiveWindow
DwmGetWindowAttribute handle, DWMWA_EXTENDED_FRAME_BOUNDS, R, LenB(R)
GetUserFormExtendedFrameRECT = R
End Function
Function PtoPx()
PtoPx = 0.75
'libre à vous d'utiliser la méthode que vous voulez
End Function
Sub test()
Dim PaN, cel As Range, R As RECT
Set cel = ActiveCell
' au cas ou la cellule ne serait pas dans la active pane
With ActiveWindow
'***********************************************************
Set PaN = .ActivePane
If Intersect(PaN.VisibleRange, cel) Is Nothing Then
Set PaN = Nothing
For i = 1 To .Panes.Count
If Not Intersect(.Panes(i).VisibleRange, cel) Is Nothing Then Set PaN = .Panes(i)
Next
End If
'*********************************************************************
If PaN Is Nothing Then MsgBox "la cellule n'est pas visible à l'ecran ": Exit Sub
l = PaN.PointsToScreenPixelsX(cel.Left) * PtoPx
t = PaN.PointsToScreenPixelsY(cel.Top) * PtoPx
End With
With UserForm1
.Show 0
.Left = l
.Top = t
'on recadre
R = GetUserFormExtendedFrameRECT
.Left = .Left - (R.Left - .Left / PtoPx)
.Top = .Top - (R.Top - .Top / PtoPx)
End With
End Sub
