【 2016年9月15日  サイト 移転のお知らせ 】
      AddinBox サイトを [ DION ] から [ さくら インターネット ] へ移転しました。  なお、旧サイト は 2017年10月 まで残します。
      この ページ の 移転先 URL  ⇒⇒  http://addinbox.sakura.ne.jp/Excel_Tips22.htm  
 
ロゴ(青) Excel/VBA Tips ロゴ(緑)

Tips22: セル位置をUserForm表示位置に変換する

ktMsgBoxアドイン (Ver 3.30) および kt関数アドイン (Ver 4.00) で追加した ktCell2Position 関数
のマクロコードです。

「シートのセル座標」と「UserFormの表示位置を示す座標」では、単位および基点が異なり、セル
の Top/Left 値 を、そのまま UserFormのTop/Left 値 へ設定する事はできません(トンデモない
予想外の位置に表示される事となります)。

その為、特定のセル位置にUserFormを表示する為には、「シートのセル座標」を「UserFormの表示
位置を示す座標」に変換する必要があります。ここで紹介する ktCell2Position 関数は、ktMsgBox
アドイン / kt関数アドイン において、メッセージボックス(ktMsgBox) や カレンダーフォーム(ktCalDate)
などを指定のセル位置に表示する為に用意した座標変換関数です。

  利用例(UserForm1 は StartUpPosition = 1 (既定値:オーナーフォーム中央) で作成する)

 Dim TargetCell As Range
 Dim vntPos As Variant

 If ( セル位置に表示する? Then
     vntPos = ktCell2Position(TargetCell)
     If IsError(vntPos) Then
         'TargetCell が表示範囲外の場合、エラー値が返ります。
         UserForm1.Show
     Else
         Load UserForm1
         With UserForm1
             .StartUpPosition = 0  '(手動)
             .Top = vntPos(0)
             .Left = vntPos(1)
             .Show
         End With
     End If
 Else
     UserForm1.Show
 End If


  ktCell2Position 関数の仕様については、kt関数アドインのヘルプを参照して下さい。

 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 = FalseAnd (AW.Split = FalseThen
        '分割なし(引数:PaneIdx は無視)
        If (Intersect(AW.VisibleRange, TargetCell) Is NothingThen
            ktCell2Position = CVErr(xlErrValue)
            Exit Function
        End If
        PaneIndex = 0
    Else
        '分割あり
        PaneIndex = 0
        If (AW.FreezePanes = TrueThen
            'ウィンドウ固定(引数:PaneIdx は無視)
            For j = 1 To AW.Panes.Count
                If Not (Intersect(AW.Panes(j).VisibleRange, TargetCell) Is NothingThen
                    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 NothingThen
                    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 NothingThen
                    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






 Home   Back Page   Next Page

ロゴ(ゴールド)   ロゴ(ゴールド)

角田 桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2016 Allrights Reserved.