XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)

#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#Else
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#End If

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X

'*** Public data initiated with 'GetScreenData'
Public PxToPt As Single    'Parameter to convert a step in pixel in point

'Pane Separator Size in Point
#If VBA7 Then
Private Const SEP_PIXSIZE = 3   '=>Estimé entre {2.7 & 3.3}
#Else
Private Const SEP_PIXSIZE = 6 '=>Estimé entre {5.7 & 6.3}
#End If
Private SeparatorSize As Long

Sub GetGridData()
    SeparatorSize = Round(SEP_PIXSIZE / PxToPt)
End Sub

' In user's module 
Sub Init()
    '(...)
    Call GetScreenData: Call GetGridData
    Application.ActiveWindow.DisplayHeadings = False
    '(...)
End Sub

' In module 'ThisWorkbook' :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '(...)
    Application.ActiveWindow.DisplayHeadings = True
    '(...)
End Sub

Sub GetScreenData()
Dim twipsPerPixelX As Long  '?? ...
Dim lngIC As Long
Dim lngRet As Long
    lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
    If lngIC <> 0 Then
        twipsPerPixelX = 1440 \ apiGetDeviceCaps(lngIC, LOGPIXELSX) 'Get the Screen X resolution
        apiDeleteDC (lngIC) 'Release the information context.
    Else    'Error : assume an average value.
        lngRet = MsgBox("Error..invalid Display Device Context..Exiting", vbOKOnly)
        Exit Sub
    End If
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
    PxToPt = (twipsPerPixelX / 20) 'Ratio convert twips to Pixel per Point
End Sub

'(Use Running Constant PxToPt, ratio to convert point'size in pixel'size)
'Give pixel'size between two lines
Function GetGapSize(sht As Worksheet, startLine As Long, endLine As Long, isWidth As Boolean, zoomRatio As Single) As Long
Dim rgArea As Range, rgLine As Range
Dim lnPx As Single ' Long
    Set rgArea = sht.Range(Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)), _
        Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)))
    If isWidth Then Set rgArea = sht.Range(sht.Cells(1, startLine), sht.Cells(1, endLine)) Else _
        Set rgArea = sht.Range(sht.Cells(startLine, 1), sht.Cells(endLine, 1))
    If zoomRatio = 1 Then
        GetGapSize = IIf(isWidth, rgArea.Width, rgArea.Height) / PxToPt
    Else
        Set rgArea = IIf(isWidth, rgArea.Columns, rgArea.Rows)
        For Each rgLine In rgArea
            lnPx = IIf(isWidth, rgLine.Width, rgLine.Height)
            If lnPx > 0 Then
                lnPx = Round(lnPx * zoomRatio / PxToPt + 0.01)  '0.01 fix round pb with xx.5
                GetGapSize = GetGapSize + lnPx
            End If
        Next rgLine
    End If
End Function

' Calcul the screen's coordinate of the top-left corner's cell
' cellTopLeft : grid's corner top-left point (CellTL)
' celPanIdx : Pane's index where CellTL is display
' Return : lXGrid, lYGrid position on screen (in Pixel)
Sub GetGridPos(ByRef lXGrid As Long, ByRef lYGrid As Long, cellTopLeft As Range, Optional celPanIdx As Integer = 1)
Dim sht As Worksheet    'Active Sheet in Active Workbook
Dim rgCrt As Range      'Current Area
Dim ratioZoom As Single 'Grid's ratio Zoom
'Pos Grid Var
Dim hideRows As Long, hideCols As Long  'Total of Hide Row and Column between Cells(1,1) and the beginning of the active's Area
Dim begRowAct As Long, endRowAct As Long, begColAct As Long, endColAct As Long  'Final active area's intervals
Dim begRowCel As Long, endRowCel As Long, begColCel As Long, endColCel As Long  'Final CellTL area's intervals
Dim rc1 As Long, rc2 As Long, cc1 As Long, cc2 As Long  'Row and Column interval of CellTL's Area between Start Area and Previous Cell's CellTL
Dim rz1 As Long, rz2 As Long, cz1 As Long, cz2 As Long  'Row and Column interval of Area(1) : (rz1,rz2) and (cz1,cz2)

Dim isOK As Boolean, isPanVert2 As Boolean, isPanHor2 As Boolean
Dim typPan As Integer   'Total Pane => 0 : 1, 1 : 2 Verticals, 2 : 2 Horizontals, 3 : 4
Dim actPanIdx As Integer   'Index of actif pane
    Set sht = ActiveWorkbook.ActiveSheet
    With Application
        With .ActiveWindow
            lXGrid = .PointsToScreenPixelsX(0)
            lYGrid = .PointsToScreenPixelsY(0)
            If (celPanIdx > 1) And Not (.FreezePanes) Then
                .SplitRow = .SplitRow: .SplitColumn = .SplitColumn  'Force separators position (between 2 range)
                isOK = True
            End If
            typPan = -(.SplitColumn > 0) - 2 * (.SplitRow > 0)
            isPanVert2 = ((celPanIdx - 1) And typPan) And 1 'True if Cell Pane is on right
            isPanHor2 = (celPanIdx - 1) And (typPan - 1)    'True if Cell Pane is on bottom
            If isOK Then    'Add pane's Sep width if panes are free
                If isPanVert2 Then lXGrid = lXGrid + SeparatorSize
                If isPanHor2 Then lYGrid = lYGrid + SeparatorSize
            End If
            ratioZoom = .Zoom / 100  'Theoretical zoom ratio
            Set rgCrt = .ActivePane.VisibleRange
            hideRows = rgCrt.Row - 1: hideCols = rgCrt.Column - 1   'Total hide line
            actPanIdx = .ActivePane.Index
            
            Set rgCrt = .Panes(celPanIdx).VisibleRange  'Get CellTL Intervals (rc1 to rc2, cc1 to cc2)
            rc1 = rgCrt.Row: rc2 = cellTopLeft.Row - 1: If rc1 > rc2 Then rc1 = 0
            cc1 = rgCrt.Column: cc2 = cellTopLeft.Column - 1: If cc1 > cc2 Then cc1 = 0
            Set rgCrt = .Panes(1).VisibleRange  'Get Pane(1) Intervals (rz1 to rz2, cz1 to cz2)
            If isPanHor2 Then
                rz1 = rgCrt.Row: rz2 = rz1 + rgCrt.Rows.Count - 1
            End If
            If isPanVert2 Then
                cz1 = rgCrt.Column: cz2 = cz1 + rgCrt.Columns.Count - 1
            End If
            
            If celPanIdx = actPanIdx Then   'if CellTL is on active pane
                begRowAct = rc1: begColAct = cc1: endRowAct = rc2: endColAct = cc2
                begRowCel = rz1: begColCel = cz1: endRowCel = rz2: endColCel = cz2
            Else
                If ((celPanIdx + 1) Xor (actPanIdx + 1)) Or typPan = 2 Then
                    begRowCel = rc1: endRowCel = rc2: begRowAct = rz1: endRowAct = rz2
                Else
                    begRowCel = rz1: endRowCel = rz2: begRowAct = rc1: endRowAct = rc2
                End If
                If (typPan And 1) And ((celPanIdx Xor actPanIdx) And 1) Then
                    begColCel = cc1: endColCel = cc2: begColAct = cz1: endColAct = cz2
                Else
                    begColCel = cz1: endColCel = cz2: begColAct = cc1: endColAct = cc2
                End If
            End If
            
            'Add the CellTL offset to coordinates
            lXGrid = lXGrid + CalCelOff(sht, True, ratioZoom, hideCols, begColCel, endColCel, begColAct, endColAct)
            lYGrid = lYGrid + CalCelOff(sht, False, ratioZoom, hideRows, begRowCel, endRowCel, begRowAct, endRowAct)
            
        End With
    End With
End Sub

'Calcul CellTL offset : interval's sum of the 'Hide Area'(ha), the 'CellTL Area' and the active Area
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'ha : Total of Hide line(s) between Cells(1,1) and the beginning of the active Area
'c1, c2 : interval(c1,c2) of the 'CellTL' Area
'a1, a2 : interval(a1,a2) of the active Area
Private Function CalCelOff(st As Worksheet, iW As Boolean, zR As Single, ha As Long, c1 As Long, c2 As Long, a1 As Long, a2 As Long) As Long
Dim r As Long
    If ha = 0 Then
        If a1 > 0 Then
            If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, c1, c2, a1, a2) Else CalCelOff = GetGapSize(st, a1, a2, iW, zR)
        Else
            If c1 > 0 Then CalCelOff = GetGapSize(st, c1, c2, iW, zR)
        End If
    Else
        If a1 > 0 Then
            If ha = a1 - 1 Then a1 = 1 Else r = GetGapSize(st, 1, ha, iW, zR)
            If c1 > 0 Then CalCelOff = r + CalCelOff2(st, iW, zR, a1, a2, c1, c2) Else CalCelOff = r + GetGapSize(st, a1, a2, iW, zR)
        Else
            If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, 1, ha, c1, c2) Else CalCelOff = GetGapSize(st, 1, ha, iW, zR)
        End If
    End If
End Function

'Calcul 2 interval's sum
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'(a,b) and (c,d) : intervals
Private Function CalCelOff2(st As Worksheet, iW As Boolean, zR As Single, a As Long, b As Long, c As Long, d As Long) As Long
Dim r As Long, e As Long, f As Long
    e = c
    If c < a Then
        f = d: c = a: d = b: a = e: b = f: e = c
    End If
    If c > b Then
        If b = c - 1 Then CalCelOff2 = GetGapSize(st, a, d, iW, zR) Else CalCelOff2 = GetGapSize(st, a, b, iW, zR) + GetGapSize(st, c, d, iW, zR)
    Else
        If c > a Then r = GetGapSize(st, a, c - 1, iW, zR)
        If b > d Then
            f = d: r = r + GetGapSize(st, d + 1, b, iW, zR)
        Else
            f = b: If d > b Then r = r + GetGapSize(st, b + 1, d, iW, zR)
        End If
        CalCelOff2 = r + 2 * GetGapSize(st, e, f, iW, zR)
    End If
End Function