k窓 ExcelVBA技ユーザーフォーム

ExcelVBA技ユーザーフォーム E13U009

E13U009 (Excel2000～2013)
ユーザーフォームをアクティブセルの位置に表示

ユーザーフォームをアクティブセルの隣にぴったり表示する方法です。
セルのスクリーン座標をポイント単位で取得する kPosCell関数を示します。マウスポインターにオートシェイプを追従させる等色々な場面で応用出来ます。
以下例では、アクティブセルの右下にユーザーフォームの左上がくるように表示しています。

セル位置に付いての配慮は必要と思われます。(引数posに画面で見えない位置を指定した等)
VisibleRangeプロパティ等で判定することが出来ます。

Window.VisibleRangeプロパティ
指定したウィンドウ内またはウィンドウ枠 (ペイン) 内に表示されているセルの範囲を表す Range オブジェクトを返します。一部しか表示されていない列や行も対象になります。

注ここに示したkPosCell関数は[ウィンドウ枠を固定]や[分割]には対応していません。これらに対応した関数は実用ツール[k蘭]にて用いていて、[k蘭]-[カレンダー]コマンドでカレンダーをポップアップ表示しています。

'標準モジュール
Option Explicit
Option Private Module
 
'kPosCell関数
'セルのスクリーン座標を取得します ポイント単位
'引数 uf ユーザーフォーム
'     psx,poy セル座標、pos セル位置(既定値はActiveCellの右下)
'     kx,ky ポイント・ピクセル変換係数
'戻り値 0=成功 -1→未対応
Function kPosCell(uf As Object, ByRef pox#, ByRef poy#, Optional pos As Range, _
  Optional ByRef kx#, Optional ByRef ky#) As Long
  If ActiveWindow.Panes.Count > 1 Then kPosCell = -1: Exit Function
  Dim zx#, zy#, pxx&, pxy&, pxx1&, pxy1&
  Dim ww&, hh&, deskw&, deskh&, ia As IAccessible
  Set ia = uf
  ia.accParent.accLocation 0, 0, ww, hh
  kx = uf.Width / ww: ky = uf.Height / hh
  If pos Is Nothing Then Set pos = ActiveCell.Offset(1, 1) '右下
  With ActiveWindow
    pxy = pos.Height / kx
    pxy1 = pxy * .Zoom / 100
    zy = pxy1 / pxy
    pxx = pos.Width / ky
    pxx1 = pxx * .Zoom / 100
    zx = pxx1 / pxx
    pox = ky * .PointsToScreenPixelsX(0) + pos.Left * zx
    poy = kx * .PointsToScreenPixelsY(0) + pos.Top * zy
  End With
End Function

'フォーム モジュール
Option Explicit

'kPosCell関数の利用例
Private Sub UserForm_Initialize()
  Dim pox#, poy#
  If kPosCell(Me, pox, poy) = -1 Then Exit Sub
  StartUpPosition = 0
  Left = pox
  Top = poy
End Sub

ExcelVBA技 ユーザーフォーム E13U009

ExcelVBA技ユーザーフォーム E13U009