XL 2010 À propos d'une courbe. Comment diable s'y sont-ils bien pris ?

Sub test()
'With ActiveWindow.ActivePane
  'P_ToPx = (.PointsToScreenPixelsY(72) - .PointsToScreenPixelsY(0)) / 72' ne fonctionne pas  sur un sheet graphique
 'End With
With ActiveSheet
For Each shap In ActiveSheet.Shapes
Debug.Print shap.Name
Next
'1.333333333333333 pour ceux qui sont en DPI 100 soit 96 ou (4/3)
Debug.Print (((.Shapes(2).Left - .Shapes(1).Left) * 1.6666666666667)) * (ActiveWindow.Zoom / 100)
End With

End Sub

Sub test()
P_toPX = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
With ActiveSheet
For Each shap In ActiveSheet.Shapes
Debug.Print shap.Name
Next
'1.333333333333333 pour ceux qui sont en DPI 100 soit 96
Debug.Print (((.Shapes(2).Left - .Shapes(1).Left) * P_toPX)) * (ActiveWindow.Zoom / 100)
End With

End Sub

Option Explicit

Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
Dim z#, q
On Error Resume Next
z = ActiveWindow.Zoom / 100
Application.Caption = x
If Not IsArray(q) Then q = GetdépartAndFinish
With Sheets("Base")
    .[C2:C3] = IIf(x < (q(1)) Or x > (q(2) * z), "#N/A", .Range("A" & Round(2 + 302 * (x - (q(1) * z)) / ((q(2) * z) - (q(1) * z)))))
    SeriesCollection(2).Points(2).DataLabel.Caption = Format(.Range("B" & Round(2 + 302 * (x - q(1)) / (q(2) - q(1)))), "0.000")
End With
Application.Caption = "depart à " & q(1) & "   fini à " & q(2) & "posision actuelle " & x & " par " & y
End Sub
Function GetdépartAndFinish()
Dim P_ToPx, x1, x2
P_ToPx = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
With ActiveSheet
x1 = (((.Shapes(2).Left - .Shapes(1).Left) * P_ToPx)) '* (ActiveWindow.Zoom / 100)'le zoom est appliqué dans le calcul dans le move
x2 = (.Shapes(3).Left * P_ToPx) '* (ActiveWindow.Zoom / 100)'le zoom est appliqué dans le calcul dans le move
GetdépartAndFinish = Array(" ", x1, x2)
End With

End Function

Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Dim ElementID&, Arg1&, Arg2&
On Error Resume Next
With SeriesCollection(1)
    .Interior.Color = RGB(200, 200, 200)
    .DataLabels.Delete
    GetChartElement X, Y, ElementID, Arg1, Arg2
    If ElementID <> 3 Then Exit Sub
    With .Points(Arg2)
        .Interior.Color = vbRed
        .ApplyDataLabels
        .DataLabel.Text = Sheets("Data").Cells(1 + Arg2, 6)
    End With
End With
End Sub