[Excel][VBA] ユーザーフォームをアクティブセルの右横に表示する実装例

0.README.md

[Excel][VBA] ユーザーフォームをアクティブセルの右横に表示する実装例

Excel用DatePickerで使っていた、セルの右側にユーザーフォームを表示する処理を整理し、共通機能をモジュール化＆実際に使ってみた実装例です。

一応、特徴としては

• DPI(Dots Per Inch)やPPI(Points Per Inch)の値をConstで決め打ちしたりせずに実装
• シートの拡大／縮小にも対応（ユーザーフォーム自体の大きさは変わりません）

といったところです。

なお、仕組みを詳しく知りたい方は、解説記事を書きましたので、そちらを御覧ください。

■ダウンロード

こちらからExcel マクロ有効ワークシートをダウンロードしてお試しください

右上にあるダウンロードボタンを押してダウンロードします。

ダウンロードされたマクロ有効ワークシート(*.xlsm)はそのままではセキュリティの関係でうまく動作しないため、ファイルのプロパティより以下のように「☑ 許可する」にチェックした上で解凍してください。

■試行方法

1. ダウンロードしたマクロ有効ワークシートを開き、マクロを有効化する
2. 「補正あり」シート上の適当なセルをダブルクリックすると、その右横にユーザーフォームが表示される
   ※「補正なし」シートの方も同様ですが、環境によってはユーザーフォームの表示位置が右下の方にずれることがあるようです。

■注意事項

動作環境

• 主として Windows 10 Pro + Microsoft 365 Excel で開発＆動作確認しているため、環境によっては動作しない可能性はあります
• WinAPIを使用している関係上、Windows以外（Mac版・Web版等）では動作しません

画面の右の方でユーザーフォームがセルの左によって表示されてしまう

環境（特にマルチモニタ環境）によっては、画面の右の方で試すとユーザーフォームが左に寄って表示されてしまう不具合が発生する場合があります。
この場合、エクセルの「ファイル＞オプション＞設定＞全般＞ユーザー インターフェイスのオプション＞複数ディスプレイを使用する場合」にて、

◉ 互換性に対応した最適化

の方にチェックを入れてからエクセルを起動し直すと改善されるかも知れません。

マルチモニタ環境で動作が不安定

マルチモニタ環境ではモニタをまたいでエクセルのウィンドウをおいていたりすると境界部分で位置がずれてしまうなどの不具合が発生するかと思いますが、現状、自分では対処困難です。
うまいやり方があればご教示願います。

■ソースコードについて

このページに貼り付けてあるソースコードは個人的に後で参照しやすいようにしてあるだけです。
また、最新版ではない可能性もありますのでご注意ください。
こちらのソースコードを参考にご自分で自由に利用・改変していただいて構いません（連絡も不要です）。
動作レポートや不具合等のご報告は歓迎します。

■免責事項

動作保証は一切ありません。ご利用の際には全て自己責任でお願いします。
不具合があったり、使用した結果等により万一何らかの損害を被ったりした場合でも、作者は一切関知いたしませんので、悪しからずご了承願います。

■関連記事

• セルの右横にユーザーフォームを出したかっただけなのに…… - 風柳メモ

ModDisplayUserForm.vba

Option Explicit

' ■ セルの右横にユーザーフォームを表示する例

Sub DisplayUserFormOnRightSideOfCell(Target As Range, Optional Calibration As Boolean = True)
    Dim TargetWindow As Window: Set TargetWindow = ActiveWindow
    
    ' ディスプレイ座標系上の対象セル(Target)の位置を取得(TargetDisplayPositionの.x/.yは共にドット(ピクセル)単位)
    Dim TargetDisplayPosition As ScreenPosition: TargetDisplayPosition = ConvertToScreenPosition(Target.Top, Target.Left, TargetWindow)
    
    ' ディスプレイ座標系上での1ポイントあたりのドット(ピクセル)数を取得
    Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint(TargetWindow)
    
    ' ユーザーフォーム表示位置のオフセット計算（左上を対象セルの左上からどれほどずらすか）
    ' ※単位はディスプレイ座標系上でのポイント数であるため、ワークシート座標系の拡大率で乗じる必要あり
    Dim WindowScale As Double: WindowScale = TargetWindow.Zoom / 100# ' ワークシート座標系の拡大率
    Dim FormTopOffset As Double: FormTopOffset = 0 * WindowScale ' Y方向はずらさない
    Dim FormLeftOffset As Double: FormLeftOffset = Target.MergeArea.Width * WindowScale ' X方向は対象セルの幅分右にずらす
    
    ' ユーザーフォームのディスプレイ座標系上での表示位置を決定（単位：ディスプレイ座標系上でのポイント数)
    Dim FormTop As Double: FormTop = (TargetDisplayPosition.y / TargetDisplayDotsPerPoint.y) + FormTopOffset
    Dim FormLeft As Double: FormLeft = (TargetDisplayPosition.x / TargetDisplayDotsPerPoint.x) + FormLeftOffset
    
    ' ユーザーフォームを指定位置に設定
    Dim FormCoordinateFactor As CoordinateFactor: FormCoordinateFactor = SetUserFormPosition(UserForm1, FormTop, FormLeft, Calibration:=Calibration)
    
    ' 座標／サイズ情報をTextBox1に出力(デバッグ用)
    With UserForm1
        .TextBox1.Text = Join(Array( _
            "[Cell] Height=" & Format(Target.Height, "0.00") & " Width=" & Format(Target.Width, "0.00"), _
            "  Top=" & Format(Target.Top, "0.00") & " Left=" & Format(Target.Left, "0.00"), _
            "  DPPY=" & Format(TargetDisplayDotsPerPoint.y, "0.00") & " DPPX=" & Format(TargetDisplayDotsPerPoint.x, "0.00"), _
            "  PosY=" & TargetDisplayPosition.y & " PosX=" & TargetDisplayPosition.x, _
            "", _
            "[Form] Height=" & Format(.Height, "0.00") & " Width=" & Format(.Width, "0.00"), _
            " Calibration: " & IIf(Calibration, "On", "Off"), _
            " Specified:", _
            "  Top=" & Format(FormTop, "0.00") & " Left=" & Format(FormLeft, "0.00"), _
            " Coordinate Factors:", _
            "  CFY=" & Format(FormCoordinateFactor.y, "0.00") & " CFX=" & Format(FormCoordinateFactor.x, "0.00"), _
            " Actual:", _
            "  Top=" & Format(.Top, "0.00") & " Left=" & Format(.Left, "0.00") _
        ), vbLf)
    End With
    
    ' ユーザーフォームの表示
    Call UserForm1.Show(vbModal)
End Sub

ModScreenCoordinates.vba

Option Explicit

'【TODO】
' - ActiveWindowが解像度が違うモニタ(デスクトップ)間にまたがっている場合にはUserFormの表示や位置が崩れてしまう(画面端にスナップした場合等にも発生)

' 【覚書】
' - 環境によってはActiveCellがActiveWindowの右の方にあるとUserFormの表示位置が左によってきてしまう場合がある（PointsToScreenPixelsXが正しい値を返さない模様）
'   → Microsoft 365のエクセルにて「ファイル＞オプション＞設定＞全般＞ユーザー インターフェイスのオプション＞複数ディスプレイを使用する場合」で
'      ○ 表示を優先した最適化 (アプリケーションの再起動が必要)
'   　 を選択していると、マルチディスプレイ環境にて発生する場合があることが判明（https://twitter.com/furyutei/status/1645413942582448129）
'      この場合には
'      ○  互換性に対応した最適化
'      に変更後、再起動すれば、改善される模様

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" (ByVal pacc As Object, phwnd As LongPtr) As LongPtr

Type ScreenPosition
    x As Double
    y As Double
End Type

Type DotsPerPoint
    x As Double
    y As Double
End Type

Type CoordinateFactor
    x As Double
    y As Double
End Type

Function ConvertToScreenPosition(TargetTop As Double, TargetLeft As Double, Optional TargetWindow As Window) As ScreenPosition
    If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
    Dim Result As ScreenPosition
    Dim PaneIndex As Long, WorkPane As Pane, WorkRange As Range
    For PaneIndex = 1 To TargetWindow.Panes.Count
        Set WorkPane = TargetWindow.Panes(PaneIndex)
        With WorkPane.VisibleRange
            If _
                ((.Top <= TargetTop) And (TargetTop < .Top + .Height)) And _
                ((.Left <= TargetLeft) And (TargetLeft < .Left + .Width)) _
            Then
                Result.x = WorkPane.PointsToScreenPixelsX(TargetLeft)
                Result.y = WorkPane.PointsToScreenPixelsY(TargetTop)
                Exit For
            End If
        End With
    Next
    ConvertToScreenPosition = Result
End Function

Function GetDisplayDotsPerPoint(Optional TargetWindow As Window) As DotsPerPoint
    If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
    Dim Result As DotsPerPoint
    Dim WindowRect As RECT
    If Application.Version < 15# Then
        ' Excel 2010以前のバージョンだとWindowオブジェクトにはhWndプロパティがない（SDIのためと思われる）
        ' →代わりにApplication.hWndを使用
        Call GetWindowRect(Application.hWnd, WindowRect)
    Else
        Call GetWindowRect(TargetWindow.hWnd, WindowRect)
    End If
    With WindowRect
        Result.x = (.Bottom - .Top) / TargetWindow.Height
        Result.y = (.Right - .Left) / TargetWindow.Width
    End With
    GetDisplayDotsPerPoint = Result
End Function

Function SetUserFormPosition(TargetForm, Top As Double, Left As Double, Optional Calibration As Boolean = True) As CoordinateFactor
    '【覚書】
    '   UserFormの表示位置(.Top/.Left)は画面左上を基点として(ポイント数で)指定するはずだが、何故か想定する位置より右下にずれてしまうことがある
    '   その場合は経験上、表示したい位置(ポイント)の値にある係数（高さと幅(.Height/.Width)の設定値と実測値の比率・例:14/15=0.9333…）を掛けるとちょうどよい位置となる模様
    Dim Result As CoordinateFactor
    With TargetForm
        .StartUpPosition = 0 ' 0:Manual, 1:CenterOwner, 2:CenterScreen, 3:WindowsDefault
        .Top = Top
        .Left = Left
        If Not Calibration Then
            Result.y = 1#: Result.x = 1#
            GoTo CLEANUP
        End If
        Dim Height As Double: Height = .Height
        Dim Width As Double: Width = .Width
        Dim FormhWnd As LongPtr: Call WindowFromObject(TargetForm, FormhWnd)
        Dim FormRect As RECT: Call GetWindowRect(FormhWnd, FormRect)
        Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint()
        Dim ActualHeight As Double: ActualHeight = (FormRect.Bottom - FormRect.Top) / TargetDisplayDotsPerPoint.y
        Dim ActualWidth As Double: ActualWidth = (FormRect.Right - FormRect.Left) / TargetDisplayDotsPerPoint.x
        Dim FormCoordinateFactorY As Double: FormCoordinateFactorY = Height / ActualHeight
        Dim FormCoordinateFactorX As Double: FormCoordinateFactorX = Width / ActualWidth
        .Top = Top * FormCoordinateFactorY
        .Left = Left * FormCoordinateFactorX
        Result.y = FormCoordinateFactorY
        Result.x = FormCoordinateFactorX
    End With

CLEANUP:
    SetUserFormPosition = Result
End Function

Sheet1.vba

Option Explicit

' ■ シート上のセルをダブルクリックしたときに、セルの右横にユーザーフォームを表示する例

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Call DisplayUserFormOnRightSideOfCell(Target)
    Cancel = True
End Sub

Sheet2.vba

Option Explicit

' ■ シート上のセルをダブルクリックしたときに、セルの右横にユーザーフォームを表示する例

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Call DisplayUserFormOnRightSideOfCell(Target, Calibration:=False) ' 補正なし
    Cancel = True
End Sub

UserForm1.vba

Option Explicit

Private Sub CommandButton1_Click()
    Unload Me
End Sub