XL 2016 VBA Challenge - Positionner un UserForm sur Objet feuille dans une feuille fractionnée

Option Explicit

'--------------------------------------------
'Position UserForm sur un objet de la feuille
'L'objet peut-être une cellule, une TexBox...
'Si l'objet n'est pas dans le Range visible
'le positionnement n'est pas effectué.
'--------------------------------------------
Sub PositionUserFormOnObject(Usf As Object, _
                             TargetObject As Object, _
                             Optional HorizontalShift As Double = 0, _
                             Optional VerticalShift As Double = 0, _
                             Optional UserFormShiftLeft As Boolean = False, _
                             Optional UserFormShiftTop As Boolean = False)
                                    
    Dim Ratio_PointToPixel As Double
    Dim Ratio_PixelToPoint As Double
    Dim Left As Double
    Dim Top As Double
    Dim Zoom As Double
    Dim InchesToPoints As Integer
    Dim Pan As Pane
    Dim OSNumber As Integer
    Dim SpecialShift As Integer
    Dim i As Integer
    Const Shift = 4
    
    'Numéro de version de l'OS
    OSNumber = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))
    'Décalage spécial
    If OSNumber = 6 And Val(Application.Version) < 16 Then SpecialShift = Shift
    
    'Récupère les coefficients de conversion Points <-> Pixels
    With ActiveWindow
        'Facteur Zoom
        Zoom = .Zoom / 100
        InchesToPoints = Application.InchesToPoints(1)

        'Coefficients Pixels <-> Points équivalents API
        Ratio_PointToPixel = (.ActivePane.PointsToScreenPixelsX(InchesToPoints) - .ActivePane.PointsToScreenPixelsX(0)) / Zoom / InchesToPoints
        Ratio_PixelToPoint = 1 / Ratio_PointToPixel
        
        'Recherche dans quel Pane se trouve l'objet cible
        For i = 1 To ActiveWindow.Panes.Count
            Set Pan = ActiveWindow.Panes(i)
            If TargetObject.Left + TargetObject.Width >= Pan.VisibleRange.Cells(1, 1).Left _
            And TargetObject.Left <= Pan.VisibleRange.Cells(1, Pan.VisibleRange.Columns.Count).Left _
                                   + Pan.VisibleRange.Cells(1, Pan.VisibleRange.Columns.Count).Width _
            And TargetObject.Top + TargetObject.Height >= Pan.VisibleRange.Cells(1, 1).Top _
            And TargetObject.Top <= Pan.VisibleRange.Cells(Pan.VisibleRange.Rows.Count, 1).Top _
                                  + Pan.VisibleRange.Cells(Pan.VisibleRange.Rows.Count, 1).Height Then Exit For
        Next i
        
        'Abandon si l'objet cible de l'affichage n'est visible nulle part.
        If i > ActiveWindow.Panes.Count Then Exit Sub
    
        'Positionne le UserForm sur l'objet cible avec les décalages demandés et le décalage spécial
        Left = (Pan.PointsToScreenPixelsX(0) * Ratio_PixelToPoint) + (TargetObject.Left + HorizontalShift + SpecialShift) * Zoom
        Top = (Pan.PointsToScreenPixelsY(0) * Ratio_PixelToPoint) + (TargetObject.Top + VerticalShift + SpecialShift) * Zoom

        'Décale le UserForm à gauche et/ou en haut de ses propres dimensions.
        If UserFormShiftLeft Then Left = Left - Usf.Width
        If UserFormShiftTop Then Top = Top - Usf.Height
    End With
    
    'Positionne le UserForm
    With Usf
        .StartUpPosition = 0
        .Left = Left
        .Top = Top
    End With
End Sub

Private Function placementActivXsheets(Obj As Object)
    If Obj Is Nothing Then Exit Function
    Dim z#, EcX#, L1#, T1#, Op&, PtoPx#, Wx#, HX#
    With ActiveWindow
        z = .Zoom / 100
        PtoPx = (.ActivePane.PointsToScreenPixelsX(72) - .ActivePane.PointsToScreenPixelsX(0)) / 72    'coeff point to pixel
        Op = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))    'number version system
        EcX = 4 And Op = 6 And Int(Val(Application.Version)) < 16  'ecart cadre
        L1 = ((.ActivePane.PointsToScreenPixelsX(Obj.Left) / PtoPx) * z) + (EcX * z)
        T1 = (.ActivePane.PointsToScreenPixelsY(Obj.top) / PtoPx) * z + (EcX * z)
        Wx = (Obj.Width / 2) * z * Px  'meme left ou milieu ou a droite(0,1,2) argument injecté dans showx
        HX = (Obj.Height / 2) * z * Py  'meme top ou milieu ou en dessous(0,1,2) argument top injecté dans showx
        L1 = L1 + (Wx)
        T1 = T1 + (HX)
        If L1 > Application.Left + Application.Width - Me.Width Then L1 = Application.Left + Application.Width - Me.Width - 15
        If T1 > Application.top + Application.Height - Me.Height Then T1 = Application.top + Application.Height - Me.Height - 15
        With Me: .Left = L1: .top = T1: End With
    End With
End Function

'----------------------------------------------------
'Returns True if the Object in argument is a UserForm
'
'TypeOf Is UserForm can't be used if the VBA Project
'has never included a UserForm because the library
'Microsoft Forms 2.0 Object Library is not present in
'the Tools/References, therefore, the UserForm type
'is not known. This function overcomes the issue.
'----------------------------------------------------
Function IsUserForm(Obj As Object) As Boolean
    Dim Usf As Object

    For Each Usf In UserForms
         If Usf Is Obj Then Exit For
    Next Usf

    If Not Usf Is Nothing Then IsUserForm = True
End Function

Private Sub placementUF(Obj As Object)
    If Not Obj Is Nothing Then
        Dim Lft As Double, Rgt As Double, top As Double, Bot As Double, P As Object, PInsWidth As Double, PInsHeight As Double
        Dim K As Double, Zom As Double, Ombre As Double, EcX As Double, OpWin As Long
        OpWin = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))    'number version system
        If OpWin = 6 Or Int(Val(Application.Version)) < 15 Then EcX = 2: Ombre = 2 Else EcX = 0: Ombre = 0     'ecart cadre
        Lft = Obj.Left: top = Obj.top: Set P = Obj.Parent    ' Normalement Page, Frame ou UserForm
        Do
            PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight    ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf P Is MSForms.Page Then Set P = P.Parent    ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): top = (top + P.top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
            Set P = P.Parent
        Loop
        Me.Left = Lft + EcX + Ombre + ((Obj.Width / 2) * Px)    ' a gauche en top
        Me.top = top + 2 + Ombre + ((Obj.Height / 2) * Py)
    End If
End Sub