Skip to content

Instantly share code, notes, and snippets.

@furyutei
Last active April 18, 2023 07:11
Show Gist options
  • Save furyutei/62f73306d9328664da855f396c9a0b45 to your computer and use it in GitHub Desktop.
Save furyutei/62f73306d9328664da855f396c9a0b45 to your computer and use it in GitHub Desktop.
[Excel][VBA] ユーザーフォームをアクティブセルの右横に表示する実装例

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

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

一応、特徴としては

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

といったところです。

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

「UserFormをアクティブセルの右横に表示する実装例 xlsm」の実行結果例

■ダウンロード

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

「UserFormをアクティブセルの右横に表示する実装例 xlsm」のダウンロード

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

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

ファイルのプロパティでセキュリティを許可する

■試行方法

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

■注意事項

動作環境

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

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

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

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

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

全般>複数ディスプレイを使用する場合は「互換性に対応した最適化」の方にしておくこと

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

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

■ソースコードについて

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

■免責事項

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

■関連記事

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
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
Option Explicit
' ■ シート上のセルをダブルクリックしたときに、セルの右横にユーザーフォームを表示する例
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Call DisplayUserFormOnRightSideOfCell(Target)
Cancel = True
End Sub
Option Explicit
' ■ シート上のセルをダブルクリックしたときに、セルの右横にユーザーフォームを表示する例
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Call DisplayUserFormOnRightSideOfCell(Target, Calibration:=False) ' 補正なし
Cancel = True
End Sub
Option Explicit
Private Sub CommandButton1_Click()
Unload Me
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment