'CellScreenPos (for Excel 2000)

'    Fix: Sgn(SplitRow) and Sgn(SplitColumn) was modified with SplitHorizontal
'    and SplitVertical.

'    This module was written aiming to know about PointsToScreenPixelsX
'    property and PointsToScreenPixelsY property in Excel 2000.


Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
    ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

'Unit
'    0: Pixels (default)
'    1: Points

Function CellScreenPos(CellRange As Range, _
        Optional Unit As Long = 0, Optional ByVal WnPane As Pane) As Variant
    Const SplitBarWidth = 6
    Const SplitBarHeight = 6
    Const RoundConst = 0.5000001
    Dim Wn As Window, ws As Worksheet
    Dim r As Range, r1 As Range, r2 As Range, vr(1 To 4) As Range
    Dim hdc As Long, px As Long, py As Long
    Dim x As Double, y As Double, x2 As Double, y2 As Double
    Dim i As Long, z As Long, sph As Long, spv As Long

    On Error GoTo ErrorHandler

    Set r = CellRange.Cells(1)
    Set ws = r.Worksheet

    If WnPane Is Nothing Then
        Set Wn = ActiveWindow
    Else
        Set Wn = WnPane.Parent
    End If

    Select Case Wn.Panes.Count
        Case 1
            Set vr(1) = Wn.VisibleRange
        Case 2
            Set vr(1) = Wn.Panes(1).VisibleRange
            Set vr(2) = Wn.Panes(2).VisibleRange
        Case 3, 4
            Set vr(1) = Wn.Panes(1).VisibleRange
            Set vr(4) = Wn.Panes(4).VisibleRange
            Set vr(2) = vr(1).Worksheet.Cells( _
                Wn.Panes(2).ScrollRow, Wn.Panes(2).ScrollColumn) _
                    .Resize(vr(1).Rows.Count, vr(4).Columns.Count)
            Set vr(3) = vr(1).Worksheet.Cells( _
                Wn.Panes(3).ScrollRow, Wn.Panes(3).ScrollColumn) _
                    .Resize(vr(4).Rows.Count, vr(1).Columns.Count)
    End Select

    If WnPane Is Nothing And Wn.FreezePanes Then
        For i = 1 To Wn.Panes.Count
            If Not Intersect(vr(i), r) Is Nothing Then Exit For
        Next
        If i > Wn.Panes.Count Then Exit Function
        Set WnPane = Wn.Panes(i)
    End If
    
    If WnPane Is Nothing Then Set WnPane = Wn.ActivePane

    Set r1 = vr(1)
    Set r2 = vr(WnPane.Index)
    If Intersect(r, r2) Is Nothing Then Exit Function

    hdc = GetDC(0)
    px = GetDeviceCaps(hdc, LOGPIXELSX)
    py = GetDeviceCaps(hdc, LOGPIXELSY)
    ReleaseDC 0, hdc: hdc = 0

    z = Wn.Zoom
    sph = Int(Wn.SplitHorizontal * px / 72 + RoundConst)
    spv = Int(Wn.SplitVertical * py / 72 + RoundConst)

    Select Case Sgn(Wn.SplitVertical) * 2 + Sgn(Wn.SplitHorizontal)
        Case 1
            If WnPane.Index = 2 Then x = sph
        Case 2
            If WnPane.Index = 2 Then y = spv
        Case 3
            Select Case WnPane.Index
                Case 2, 4: x = sph
            End Select
            Select Case WnPane.Index
                Case 3, 4: y = spv
            End Select
    End Select

    If x > 0 Then If Not Wn.FreezePanes Then x = x + SplitBarWidth
    If y > 0 Then If Not Wn.FreezePanes Then y = y + SplitBarHeight

    x = x + Wn.PointsToScreenPixelsX(0)
    y = y + Wn.PointsToScreenPixelsY(0)

    If (z \ 100) * 100 = z Then
        x = x + Int(r1.Left * px * z / 7200 + RoundConst)
        y = y + Int(r1.Top * py * z / 7200 + RoundConst)
        x = x + Int((r.Left - r2.Left) * px * z / 7200 + RoundConst)
        y = y + Int((r.Top - r2.Top) * py * z / 7200 + RoundConst)
        x2 = x + Int(r.Width * py * z / 7200 + RoundConst)
        y2 = y + Int(r.Height * py * z / 7200 + RoundConst)
    Else
        For i = 1 To r1.Column - 1
            x = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)
        Next
        For i = r2.Column To r.Column - 1
            x = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)
        Next
        x2 = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)

        For i = 1 To r1.Row - 1
            y = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
        Next
        For i = r2.Row To r.Row - 1
            y = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
        Next
        y2 = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
    End If

    If Unit = 1 Then
        x = x * 72 / px
        y = y * 72 / py
        x2 = x2 * 72 / px
        y2 = y2 * 72 / py
    End If
    CellScreenPos = Array(x, y, x2, y2)
    Exit Function

ErrorHandler:
    If hdc <> 0 Then ReleaseDC 0, hdc
    Exit Function
End Function


Sub Test_CellScreenPos()
    Dim a As Variant
    a = CellScreenPos(ActiveCell)
    If IsArray(a) Then
        With Application.CommandBars("Fill Color")
            .Position = msoBarFloating
            .Left = a(0)
            .Top = a(3)
            .Visible = True
        End With
    End If
End Sub

'Sub Test_CellScreenPos_2()
'    Dim a As Variant
'    a = CellScreenPos(ActiveCell, 1)
'    If IsArray(a) Then
'        With UserForm1
'            .StartUpPosition = 0
'            .Left = a(2)
'            .Top = a(3)
'            .Show
'        End With
'    End If
'End Sub