選択セルの直下にユーザーフォームを表示させます。

「選択セルの直下」は以前からできていました。

(画像をクリックすると、このページのサンプルがダウンロードできます)

通常はこんな感じです。どこかのセルをダブルクリックするとそのセルの下にユーザーフォームが表示されます。
(Office2003まではこれもできませんでした)



しかし、スクリーン下端付近だと、



こうなってしまうし、スクリーン右端付近だと、



こうなってしまう状態でした。
この時点では、単に指定セル直下というだけでユーザーフォームがスクリーンの範囲から「はみ出る」かの判定は行なっていませんから当然の結果です。

これをある程度は改善できました。

「ある程度」というのは、全てのケースで完璧ではないということを指しています。まず一般的なケースで見てみましょう。



スクリーン下端付近だと、



このように指定セルの上に表示されるようになり、スクリーン右端付近だと、



このようにユーザーフォーム全体が表示される位置まで左に移動した位置に表示されます。
ユーザーフォームがスクリーンの範囲から「はみ出る」かの判定と、補正方法が今回の問題でした。



今回、以下の物を取得する方法が見つかりました。

• 複数スクリーン利用でもそれらを並べた全体矩形範囲の縦横位置範囲の取得
• メインスクリーンのサイズ、及びそのワーキングエリアのサイズから高さの差し引きでタスクバーの高さを取得

これらにより、全体矩形範囲からスクリーン下方にタスクバーがあるものとして、その高さ分を差し引いたものを有効全体矩形範囲として「はみ出る」かの判定を行なっています。



従来から行なっている「指定セル直下にユーザーフォームを表示」というのはユーザーフォームの左上の縦横方向のアドレスを指定するものです。
例えば、スクリーン下端からはみ出るかであれば、ユーザーフォーム左上の縦方向位置にユーザーフォームの高さを足したものが有効全体矩形範囲の高さを超えたら「はみ出る」と判断すれば良いことになります。
現在のサンプルはこの方法で処理しています。



「はみ出し」時の制御は、縦方向の時はユーザーフォームの現在位置からユーザーフォームの高さと表示セルの高さを差し引きます。 これで、セルの上に表示されることになりますが、若干「誤差」的なズレが起きることがあるようです。
横方向の時は、セル左側へ移動ではなく、スクリ－ン右端からユーザーフォームの幅を差し引いた位置にユーザーフォームを表示させるので、 スクリ－ン右端にピッタリ合った位置にユーザーフォームが表示されます。



現在では、ダウンロードの「カレンダー入力用フォーム」も同様の動作なのですが、 このページでは「ユーザーフォーム表示位置の制御」に傾注するために他用途の記述がないサンプルを作成して紹介しています。
先頭画像からダウンロードできるサンプルではVBE側でユーザーフォームの大きさなどを変更しても動作確認できるのでご利用下さい。



最初に「ある程度」と言っているのは、この方法でもはみ出してしまうケースが避けられないからです。 そのケースの説明は下記ソースコードの紹介の後に記載しています。

それではソースコードです。

このページのサンプルは、どこかのセルをダブルクリックするとそのセルの下にユーザーフォームが表示させるというものなので、 ワークシートの「Worksheet_BeforeDoubleClick」イベント記述が起点となります。
まずはそのコードです。

'***************************************************************************************************
'   ユーザーフォーム位置制御テスト                                  Sheet1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'19/12/08(1.00)新規作成
'***************************************************************************************************
Option Explicit

'***************************************************************************************************
'　■■■ Worksheetイベント ■■■
'***************************************************************************************************
'* 処理名　：Worksheet_BeforeDoubleClick
'* 機能　　：ワークシートダブルクリッククリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    '-----------------------------------------------------------------------------------------------
    ' テストフォームを表示させる
    Call ShowFormFromRange(Target)
    ' セル選択はキャンセル
    Cancel = True
End Sub

'----------------------------------------<< End of Source >>----------------------------------------

「Worksheet_BeforeDoubleClick」イベント記述は実に簡単なもので、コメントを除くと実質2行しかありません。
「Call ShowFormFromRange(Target)」の方が実際にユーザーフォームを表示させる処理で、選択セルを引数で通知して呼び出します。
「Cancel = True」の方は本来のセルのダブルクリック動作をキャンセルする記述です。

次がここでの本来の動作記述があるモジュール「modTestForm」です。
上記のワークシートから呼び出される「ShowFormFromRange」プロシージャもこの中の上の方にあります。
「ShowFormFromRange」プロシージャの中で「テストフォーム(TestForm)」を呼び出していますが、 この部分を変更すれば他のユーザーフォームにもそのまま流用できると思います。
先頭の方にある「#Const g_cnsAdjust = 1」はテスト用の記述です。 「.. = 0」に変更するとユーザーフォームはセル直下に表示されるだけで「はみ出し」制御が行なわれない動作になります。

'***************************************************************************************************
'   ユーザーフォーム位置制御テスト                                  modTestForm(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'19/12/08(1.00)新規作成
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
#Const g_cnsAdjust = 1          ' ← 0=下端・右端制御しない、1=下端・右端制御する
'---------------------------------------------------------------------------------------------------
Public Const g_cnsTitle As String = "ユーザーフォーム位置制御テスト"
'---------------------------------------------------------------------------------------------------
' フォーム位置制御関連
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const SM_CYSCREEN As Long = 1
Private Const SM_XVIRTUALSCREEN As Long = 76
Private Const SM_YVIRTUALSCREEN As Long = 77
Private Const SM_CXVIRTUALSCREEN As Long = 78
Private Const SM_CYVIRTUALSCREEN As Long = 79
Private Const SPI_GETWORKAREA As Long = 48
'---------------------------------------------------------------------------------------------------
' GetWindowRect用ユーザー定義
Private Type g_typRect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
' 64ビット版判定
#If VBA7 Then
' ■GetDC(API)
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
' ■ReleaseDC(API)
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" _
    (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
' ■GetDeviceCaps(API)
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" _
    (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
' ■GetSystemMetrics(API)
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
' ■SystemParametersInfo(API)
Private Declare PtrSafe Function SystemParametersInfo Lib "user32.dll" _
    Alias "SystemParametersInfoA" ( _
    ByVal uAction As Long, _
    ByVal uParam As Long, _
    ByRef lpvParam As g_typRect, _
    ByVal fuWinIni As Long) As Long
#Else
' ■GetDC(API)
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
' ■ReleaseDC(API)
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
' ■GetDeviceCaps(API)
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
' ■GetSystemMetrics(API)
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
' ■SystemParametersInfo(API)
Private Declare Function SystemParametersInfo Lib "user32.dll" _
    Alias "SystemParametersInfoA" ( _
    ByVal uAction As Long, _
    ByVal uParam As Long, _
    ByRef lpvParam As g_typRect, _
    ByVal fuWinIni As Long) As Long
#End If

'***************************************************************************************************
'　■■■ ワークシートからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：ShowFormFromRange
'* 機能　　：セル(Range)から表示させる
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = セル(Object) ※単一セル又は結合したセル
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：当該セルの下にテストフォームが表示される
'* 注意事項：
'***************************************************************************************************
Public Sub ShowFormFromRange(ByRef objRange As Range)
    '-----------------------------------------------------------------------------------------------
    Dim lngLeft As Long                                             ' 横位置
    Dim lngTop As Long                                              ' 縦位置
    ' 非結合のセル範囲を選択している時は処理しない
    If objRange.Count > 1 Then
        ' 単一結合セルはOK とする
        If objRange.Address <> objRange.Cells(1).MergeArea.Address Then Exit Sub
    End If
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォーム表示位置取得
    Call FP_GetFormPosition(objRange, TestForm.Width, TestForm.Height, lngLeft, lngTop)
    '-----------------------------------------------------------------------------------------------
    ' テストフォーム
    With TestForm
        ' フォーム表示位置の確認
        If ((lngLeft <> 0) Or (lngTop <> 0)) Then
            ' 指定がある場合はマニュアル指定
            .StartUpPosition = 0
            .Left = lngLeft
            .Top = lngTop
        Else
            ' 指定がない場合はスクリーンの中央
            .StartUpPosition = 2
        End If
        ' テストフォームを表示
        .Show
    End With
End Sub

'***************************************************************************************************
'　■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名　：FP_GetFormPosition
'* 機能　　：ユーザーフォーム表示位置取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 対象セル(Object)
'* 　　　　　Arg2 = ユーザーフォームの幅(Long)
'* 　　　　　Arg3 = ユーザーフォームの高さ(Long)
'* 　　　　　Arg4 = スクリーン上の横位置(Long)          ※Ref参照
'* 　　　　　Arg5 = スクリーン上の縦位置(Long)          ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：セルの真下にフォームを表示させる位置を取得
'* 注意事項：取得できない時は横位置､縦位置ともゼロとなる
'***************************************************************************************************
Private Function FP_GetFormPosition(ByRef objRange As Range, _
                                    ByVal lngFormWidth As Long, _
                                    ByVal lngFormHeight As Long, _
                                    ByRef lngFormLeft As Long, _
                                    ByRef lngFormTop As Long) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objTarget As Range                                          ' 対象セル(先頭セル)
    Dim objAW As Window                                             ' ActiveWindow
    Dim lngPaneIx As Long                                           ' PaneIndex(0～4)
    Dim lngIx As Long                                               ' ループ用INDEX(Work)
    Dim lngR1C1Left As Long                                         ' 起点セル左端位置
    Dim lngR1C1Top As Long                                          ' 起点セル上端位置
    Dim lngTargetLeft As Long                                       ' 対象セル左端位置
    Dim lngTargetTop As Long                                        ' 対象セル上端位置
    Dim lngScreenRight As Long                                      ' スクリーン右端位置
    Dim lngScreenBottom As Long                                     ' スクリーン下端位置
    Dim lngDPIX As Long                                             ' Dots Per Inch(水平)
    Dim lngDPIY As Long                                             ' Dots Per Inch(垂直)
    Dim lngPPI As Long                                              ' Pixels Per Inch
    FP_GetFormPosition = False
    lngFormLeft = 0
    lngFormTop = 0
    lngPaneIx = 0
    Set objTarget = objRange.Cells(1).MergeArea
    Set objAW = ActiveWindow
    '-----------------------------------------------------------------------------------------------
    ' ウィンドウ分割無しか
    If Not objAW.FreezePanes And Not objAW.Split Then
        ' 表示域外は無視
        If Intersect(objAW.VisibleRange, objTarget) Is Nothing Then Exit Function
    Else            ' 分割あり
        ' ウィンドウ枠固定か
        If objAW.FreezePanes Then
            ' どのウィンドウに属するか判定
            For lngIx = 1 To objAW.Panes.Count
                ' 発見？
                If Not Intersect(objAW.Panes(lngIx).VisibleRange, objTarget) Is Nothing Then
                    lngPaneIx = lngIx
                    Exit For
                End If
            Next lngIx
            ' 見つからないか
            If lngPaneIx = 0 Then Exit Function
        Else
            ' ウィンドウ分割はアクティブペインのみ判定
            If Not Intersect(objAW.ActivePane.VisibleRange, objTarget) Is Nothing Then
                lngPaneIx = objAW.ActivePane.Index
            Else
                Exit Function
            End If
        End If
    End If
    '-----------------------------------------------------------------------------------------------
    ' ※以下はExcel2003以前では動作しない
    lngDPIX = FP_GetDPIX
    lngDPIY = FP_GetDPIY
    lngPPI = FP_GetPPI
    ' ウィンドウ分割無しか
    If lngPaneIx = 0 Then
        lngR1C1Left = objAW.PointsToScreenPixelsX(0)
        lngR1C1Top = objAW.PointsToScreenPixelsY(0)
    Else
        lngR1C1Left = objAW.Panes(lngPaneIx).PointsToScreenPixelsX(0)
        lngR1C1Top = objAW.Panes(lngPaneIx).PointsToScreenPixelsY(0)
    End If
    lngTargetLeft = ((objTarget.Left * (lngDPIX / lngPPI)) * (objAW.Zoom / 100)) + lngR1C1Left
    lngTargetTop = (((objTarget.Top + objTarget.Height) * (lngDPIY / lngPPI)) * (objAW.Zoom / 100)) + lngR1C1Top
    lngFormLeft = lngTargetLeft * (lngPPI / lngDPIX)
    lngFormTop = lngTargetTop * (lngPPI / lngDPIY)
    '-----------------------------------------------------------------------------------------------
    ' 下端・右端制御しない時は終了
#If g_cnsAdjust <> 1 Then
    FP_GetFormPosition = True
    Exit Function
#End If
    ' スクリーンサイズ位置の取得
    Call GP_GetScreenPos(0, 0, lngScreenRight, lngScreenBottom)
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォームがスクリーンからはみ出すか(横)
    If (lngFormLeft + lngFormWidth) * (lngDPIX / lngPPI) > lngScreenRight Then
        ' スクリーン右端に移動(+3は誤差？)
        lngFormLeft = lngScreenRight * (lngPPI / lngDPIX) - lngFormWidth + 3
    End If
    ' ユーザーフォームがスクリーンからはみ出すか(縦)
    If (lngFormTop + lngFormHeight) * (lngDPIY / lngPPI) > lngScreenBottom Then
        ' セル上端に移動
        lngFormTop = lngFormTop - (objRange.Height + lngFormHeight)
    End If
    FP_GetFormPosition = True
End Function

'***************************************************************************************************
'* 処理名　：FP_GetPPI
'* 機能　　：PPI(Pixels Per Inch)取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：PPI値(Long)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetPPI() As Long
    '-----------------------------------------------------------------------------------------------
    FP_GetPPI = Application.InchesToPoints(1)
End Function

'***************************************************************************************************
'* 処理名　：FP_GetDPIX
'* 機能　　：DPI(Dots Per Inch)取得(水平方向)
'---------------------------------------------------------------------------------------------------
'* 返り値　：DPI値(Long)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetDPIX() As Long
    '-----------------------------------------------------------------------------------------------
    FP_GetDPIX = FP_GetDPI(LOGPIXELSX)
End Function

'***************************************************************************************************
'* 処理名　：FP_GetDPIY
'* 機能　　：DPI(Dots Per Inch)取得(垂直方向)
'---------------------------------------------------------------------------------------------------
'* 返り値　：DPI値(Long)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetDPIY() As Long
    '-----------------------------------------------------------------------------------------------
    FP_GetDPIY = FP_GetDPI(LOGPIXELSY)
End Function

'***************************************************************************************************
'* 処理名　：FP_GetDPI
'* 機能　　：DPI(Dots Per Inch)取得(API)
'---------------------------------------------------------------------------------------------------
'* 返り値　：DPI値(Long)
'* 引数　　：Arg1 = nFlag(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetDPI(ByVal nFlag As Long) As Long
    '-----------------------------------------------------------------------------------------------
#If VBA7 Then
    Dim lngHdc As LongPtr                                           ' ウィンドウハンドルのDC
#Else
    Dim lngHdc As Long                                              ' ウィンドウハンドルのDC
#End If
    lngHdc = GetDC(Application.hwnd)
    FP_GetDPI = GetDeviceCaps(lngHdc, nFlag)
    Call ReleaseDC(&H0, lngHdc)
End Function

'***************************************************************************************************
'* 処理名　：GP_GetScreenPos
'* 機能　　：スクリーン位置の取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = スクリーン左端位置(Long)              ※Ref参照
'* 　　　　　Arg2 = スクリーン上端位置(Long)              ※Ref参照
'* 　　　　　Arg3 = スクリーン右端位置(Long)              ※Ref参照
'* 　　　　　Arg4 = スクリーン下端位置(Long)              ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月08日
'* 作成者　：井上　治
'* 更新日　：2019年12月08日
'* 更新者　：井上　治
'* 機能説明：複数スクリーン全体四隅の位置を取得
'* 注意事項：
'***************************************************************************************************
Private Sub GP_GetScreenPos(ByRef lngScreenLeft As Long, _
                            ByRef lngScreenTop As Long, _
                            ByRef lngScreenRight As Long, _
                            ByRef lngScreenBottom As Long)
    '-----------------------------------------------------------------------------------------------
    Dim lngWidth As Long                                            ' スクリーンの幅
    Dim lngHeight As Long                                           ' スクリーンの高さ①
    Dim lngHeight2 As Long                                          ' スクリーンの高さ②
    Dim lngHeight3 As Long                                          ' スクリーンの高さ③
    Dim objRect As g_typRect                                        ' Rect
    ' スクリーンの左端､上端､幅､高さの取得(複数スクリーン対応)
    lngScreenLeft = GetSystemMetrics(SM_XVIRTUALSCREEN)         ' 左端
    lngScreenTop = GetSystemMetrics(SM_YVIRTUALSCREEN)          ' 上端
    lngWidth = GetSystemMetrics(SM_CXVIRTUALSCREEN)             ' 幅(仮想スクリーン域)
    lngHeight = GetSystemMetrics(SM_CYVIRTUALSCREEN)            ' 高さ(仮想スクリーン域)
    lngHeight2 = GetSystemMetrics(SM_CYSCREEN)                  ' 高さ(メインスクリーンのみ)
    ' タスクバーを除くスクリーンの大きさ取得(メインスクリーンのみ)
    Call SystemParametersInfo(SPI_GETWORKAREA, 0, objRect, 0)
    lngHeight3 = objRect.Bottom - objRect.Top                   ' 高さ(メインのタスクバー以外の分)
    ' タスクバーがメインスクリーンの下端にあるものとし、この高さを差し引く
    lngHeight = lngHeight - (lngHeight2 - lngHeight3)
    ' 右端の算出
    lngScreenRight = lngWidth - lngScreenLeft
    ' 下端の算出
    lngScreenBottom = lngHeight - lngScreenTop
End Sub

'----------------------------------------<< End of Source >>----------------------------------------

上方で説明した、

• 複数スクリーン利用でもそれらを並べた全体矩形範囲の縦横位置範囲の取得
• メインスクリーンのサイズ、及びそのワーキングエリアのサイズから高さの差し引きでタスクバーの高さを取得

は、この最後の「GP_GetScreenPos」プロシージャが行なっています。
単一スクリーンでも複数スクリーンでも、スクリーン全体域四隅の位置座標を返す仕組みとなっており、 タスクバーがメインスクリーンの下端にあるものとして全体域の下側からタスクバーは差し引かれます。



スクリーン全体域四隅の位置座標を返しますが、このページのサンプルのユーザーフォームは下か右にしかはみ出さないので、左と上は呼び出し元では利用していません。

どういう時に正しく動作できないか

様々なケースでの動作確認まではできていませんが、正しく動作できないであろうケースは以下のようなケースです。
スクリーンごとのワーキングエリア(操作可能範囲)、スクリーンごとのDPI/PPI値が取得できない以上、 「はみ出る」ケースの判定が正しくできないケースが発生します。 当然ながら複数スクリーン時のみの現象です。

• 複数スクリーン利用で、配置上で各スクリーンの下端が合っていない
  ⇒全体矩形範囲の判定なので、上に上がっている方のスクリーンでは下端「はみ出し」が発生します。
• DPI値の異なるディスプレィを並べた場合の影響
  ⇒高解像ノートPCに大型ディスプレィを接続したような場合に起きます。
  手元にある環境で、13.3インチモニタのノートPC(1920×1080px)に 22インチ外部ディスプレィ(1920×1080px)を接続してみました。
  外部ディスプレィをノートPCの左側に配置される状態です。
  
  Windows上では1920×1080px同士なので、このように同じサイズのディスプレィが横に並んでいるようになっています。
  しかし、個々のディスプレィの実際の文字サイズの設定は外部ディスプレィは通常の100％(96DPI)なのですが、 ノートPCの方はデフォルトが150％(144DPI)なのです。 上記の全体矩形範囲は4800×1620pxと判断されました。(タスクバー分差し引き前)
  結果でどうなるかというと、外部ディスプレィ側は所望した通りの動作になりますが、ノートPC側は「はみ出し」が発生します。 これはメインスクリーンであるノートPCが150％(144DPI)であるため、 全体矩形範囲は4800×1620pxと判断されるのに対し、 ノートPC自身は1920×1080pxなので、ノートPC側でスクリーン下端を判断するのに 縦方向が1620pxに満たないため「はみ出さない」という判断になるからです。