Public Function ktCell2Position(ByRef Target As Range, _
Optional ByVal PaneIdx As Integer = 0) As Variant
'Pane.PointsToScreenPixelsX メソッドは Excel2007〜
'PaneIdx:
' [ウィンドウ枠分割]時に指定します。
' 位置(Target)がActiveCell(ActivePane)以外で、
' マクロによる直接指定の際に対象Paneを指定します。
' [ウィンドウ枠固定]時は指定不要です。
' Targetから対象Pane を自動検出します。
Dim TargetCell As Range 'Single Cell
Dim AW As Window 'ActiveWindow
Dim PaneIndex As Integer
Dim R1C1Top As Long
Dim R1C1Left As Long
Dim TargetTop As Long
Dim TargetLeft As Long
Dim UF_Left As Long 'UserForm Position
Dim UF_Top As Long
Const DPI As Long = 96 'dots per inch
Const PPI As Long = 72 'pixel per inch
Dim j As Integer
' ( セルへの記述は不可 )
If (TypeName(Application.Caller) = "Range") Then
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
Set AW = ActiveWindow
Set TargetCell = Target.Cells(1) 'セル範囲などの場合もあるので先頭セルを取り出す
If (AW.FreezePanes = False) And (AW.Split = False) Then
'分割なし（引数：PaneIdx は無視）
If (Intersect(AW.VisibleRange, TargetCell) Is Nothing) Then
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
PaneIndex = 0
Else
'分割あり
PaneIndex = 0
If (AW.FreezePanes = True) Then
'ウィンドウ固定（引数：PaneIdx は無視）
For j = 1 To AW.Panes.Count
If Not (Intersect(AW.Panes(j).VisibleRange, TargetCell) Is Nothing) Then
PaneIndex = j
Exit For
End If
Next j
If (PaneIndex = 0) Then
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
Else
'ウィンドウ分割
If (PaneIdx = 0) Then
If Not (Intersect(AW.ActivePane.VisibleRange, TargetCell) Is Nothing) Then
PaneIndex = AW.ActivePane.Index
Else
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
Else
If (PaneIdx < 0) Or (PaneIdx > AW.Panes.Count) Then
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
'[PaneIdx : 1〜4]
If Not (Intersect(AW.Panes(PaneIdx).VisibleRange, TargetCell) Is Nothing) Then
PaneIndex = PaneIdx
Else
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
End If
End If
End If
'PaneIndex
' 0: 分割なし
' 1: 左上(4面)/左(左右)/上(上下)
' 2: 右上(4面)/右(左右)/下(上下)
' 3: 左下(4面)
' 4: 右下(4面)
'PaneオブジェクトのPointsToScreenPixelsY/X はExcel2007以降で可
'[〜Excel2003]vs[Excel2007]では条件付きコンパイルは使えない
If (PaneIndex = 0) Then
R1C1Top = AW.PointsToScreenPixelsY(0)
R1C1Left = AW.PointsToScreenPixelsX(0)
Else
'[Pane=1〜4]
If (Val(Application.Version) < 12) Then
'[〜Excel2003]
If (PaneIndex = 1) Then
R1C1Top = AW.PointsToScreenPixelsY(0)
R1C1Left = AW.PointsToScreenPixelsX(0)
Else
ktCell2Position = CVErr(xlErrValue)
Exit Function
End If
Else
'[Excel2007〜]
'Excel2003以前での実行時エラー(コンパイルエラー)回避の為に
'Error句を入れておく
On Error Resume Next
R1C1Top = AW.Panes(PaneIndex).PointsToScreenPixelsY(0)
R1C1Left = AW.Panes(PaneIndex).PointsToScreenPixelsX(0)
On Error GoTo 0
End If
End If
TargetTop = ((Target.Top * (DPI / PPI)) * (AW.Zoom / 100)) + R1C1Top
TargetLeft = ((Target.Left * (DPI / PPI)) * (AW.Zoom / 100)) + R1C1Left
UF_Top = TargetTop * (PPI / DPI)
UF_Left = TargetLeft * (PPI / DPI)
ktCell2Position = Array(UF_Top, UF_Left)
End Function
|
