Autres [Résolu]Affichage userform sur cellule ou activX version simplifiée a tester

Public Sub Posit(ByVal Obj As Object, Optional ByVal X As Double, Optional ByVal Y As Double)
    Rem. ——— Vous pouvez au préalable positionner l    'UserForm par rapport à quelque chose.
'     Obj: Ce par rapport à quoi vous voulez le positionner. X et Y indiqueront comment :
'     X: -1: Collé au coté gauche, 0: Centré horizontalement, 1: Collé au coté droit.
'     Y: -1: Collé au bord supérieur, 0: Centré verticalement, 1: Collé juste en dessous.
'     Mais si la valeur absolue de X >= 1, Y:=0.9 est une valeur conventionnelle demandant
'        à ce que le bord supérieur du calendrier soit aligné sur celui de Obj.
'     D'autres valeurs entraineront un recouvrement partiel ou un certain éloignement.
'     Mais rien ne vous empêche de rectifier encore ensuite la propriété Left ou Top
'     de l'UFmCalend pour ajouter un interstice en points au bord de l'objet. Mais toujours
'        avant le Show, donc avant utilisation de la méthode Saisie.
'     X et Y sont facultatifs et assumés = 0. Il est donc centré sur l'objet Obj si non précisés.
    Dim Lft As Double, Rgt As Double, Top As Double, Bot As Double, U As Object, _
        UInsWidth As Single, UInsHeight As Single, K As Double, Zom As Double, Px72 As Long, Trnq As Long
    If TypeOf Obj Is MSForms.Control Then
        Lft = Obj.Left: Top = Obj.Top: Set U = Obj.Parent    ' Normalement Page, Frame ou UserForm
        Do: UInsWidth = U.InsideWidth: UInsHeight = U.InsideHeight    ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf U Is MSForms.Page Then Set U = U.Parent    ' Prend le Multipage, car le Page est sans positionnement.
            K = (U.Width - UInsWidth) / 2
            Lft = Lft + U.Left + K
            Top = Top + U.Top + U.Height - K - UInsHeight
            If Not (TypeOf U Is MSForms.Frame Or TypeOf U Is MSForms.MultiPage) Then Exit Do
            Set U = U.Parent: Loop
        Rgt = Lft + Obj.Width: Bot = Top + Obj.Height
    Else
        With ActiveWindow
            Zom = .Zoom / 100
            Px72 = (.PointsToScreenPixelsX(Cells.Width) - .PointsToScreenPixelsX(0)) / Cells.Width
            If .FreezePanes Then
                Lft = Obj.Left: Trnq = Int(Lft / 3) * 3
                Lft = .ActivePane.PointsToScreenPixelsX(Trnq) * 72 / Px72 + (Lft - Trnq)
            Else
                Lft = .PointsToScreenPixelsX(Int(Obj.Left * Zom * Px72 / 72 + 0.5)) * 72 / Px72
            End If
            'Px72 = GetDeviceCaps(GetDC(0), 90)
            If .FreezePanes Then
                Top = Obj.Top: Trnq = Int(Top / 3) * 3
                Top = .ActivePane.PointsToScreenPixelsY(Trnq) * 72 / Px72 + (Top - Trnq)
            Else
                Top = .PointsToScreenPixelsY(Int(Obj.Top * Zom * Px72 / 72 + 0.5)) * 72 / Px72
            End If
            Rgt = Lft + Obj.Width * Zom: Bot = Top + Obj.Height * Zom
        End With
    End If
    Me.Left = (X * (Rgt - Lft + Me.Width + 6) + Lft + Rgt - Me.Width - 6) / 2 + 3
    If Abs(X) >= 1 And Y = 0.9 Then
        Me.Top = Top
    ElseIf Abs(X) >= 1 And Y = -0.9 Then
        Me.Top = Bot - Me.Height
    Else
        Me.Top = (Y * (Bot - Top + Me.Height + 6) + Top + Bot - Me.Height - 6) / 2 + 3
    End If
End Sub

Sub test3(obj As Object)


    Dim Z#, EcX#, EcY#, L1#, T1#, BandH As Range, BandV As Range, H#, L#
    With ActiveWindow
        Z = (ActiveWindow.Zoom / 100)
        EcX = 2
        EcY = 3

        L1 = (.ActivePane.PointsToScreenPixelsX(obj.Left) / PtoPx) * Z + EcX
        T1 = .ActivePane.PointsToScreenPixelsY(obj.Top) / PtoPx * Z + EcX

        If .SplitRow > 0 Then
            r = Cells(.SplitRow, 1).Row
            If obj.Row < r And .ScrollRow > r + 1 Then
                MsgBox "scrollvertical a rattraper  " & Range(Cells(r + 1, 1), .VisibleRange.Cells(1).Offset(-1)).EntireRow.Address
                T1 = T1 + ((Range(Cells(r + 1, 1), .VisibleRange.Cells(1).Offset(-1)).Height) * Z) - (EcX * Z)
            End If
        End If


        If .SplitColumn > 0 Then
            c = Cells(1, .SplitColumn).Column
            If obj.Column < c + 1 And .ScrollColumn > c + 1 Then
                MsgBox "scrollhorizontal a rattraper  " & Range(Cells(1, c + 1), .VisibleRange.Cells(1).Offset(, -1)).EntireColumn.Address
                L1 = L1 + ((Range(Cells(1, c + 1), .VisibleRange.Cells(1).Offset(, -1)).Width) * Z)
            End If
        End If

    End With

    With UserForm1
        .Show 0
        .Left = L1
        .Top = T1
    End With

End Sub
Private Function PtoPx()
    With ActiveWindow.ActivePane:
        PtoPx = (.PointsToScreenPixelsX(Cells.Width) - .PointsToScreenPixelsX(0)) / Cells.Width
    End With
End Function

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
test3 Target
End Sub