VBAでマルチモニタ情報を得よう

相変わらずExcel VBAをいじってます。
VBAで、ディスプレイ周りの話なら、こちらも参考にしてほしい。

https://minimashia.net/vba-form-excel-center

2019.09.24

めっちゃ簡単だけど、簡単だからこそやってほしい。「そんなのいらないでしょ」って思う人はデュアルディスプレイではありませんね？デュアルディスプレイだと、Formだけが別のディスプレイの端っこに出たりするのです。Public Sub FormPositionSet(ByRef form As Object) form.StartUpPosition = 0 form.Top = Application.Top + ((Application.Height - form.Height) / 2) form.Left = Application.Left + ((Application.Width - form.Width) / 2)End Subこれだけ。Fromの中でMe.StartUpPosition = 0;…とやっていっても良い...

みにましあ

https://minimashia.net/vba-get-dpi

2020.08.25

VBAでDPI値を知りたいお年頃

DPI値っていうと堅苦しいけど、要は、ディスプレイ設定の「テキスト、アプリ、その他の項目のサイズ」ってやつが100%かどうかを知りたいお年頃です。いくつか方法があるのでつらつらと説明していきます。これね。GetDpiForMonitorで取得するこのコードを書いたExcelブックを起動した状態のまま、テキストサイズを変更しても最新値は取れないので、Excelブックの再起動が必要です。Option ExplicitPrivate Const S_OK = 0Private Enum MONITOR_DPI_TYPE MDT_EFFECTIVE_DPI = 0 MDT_ANGULAR_DPI = 1 MDT_RAW_DPI = 2 MDT_DEFAULT = M...

今回はExcelのウィンドウ位置を邪魔にならないところに自動配置したかった。
が、マルチディスプレイのときにどうすんじゃい。
というわけで、ディスプレイの情報を全部チェックして、Excelの今いるモニタを取得する。
古い人間なので、ハンガリアン記法が好きです。

Option Explicit

' EnumDisplayMonitorsで使用するためのRECT構造体宣言
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If Win64 Then
    Private Declare PtrSafe Function EnumDisplayMonitors Lib "User32" (ByVal hdc As LongPtr, ByVal lprcClip As Long, ByVal lpfnEnum As LongPtr, ByVal dwData As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function EnumDisplayMonitors Lib "User32" (ByVal hdc As Long, ByVal lprcClip As Long, ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
    Private Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
#End If

' EnumDisplayMonitorsで取得するモニタ情報を格納するためのメンバ変数
Private coMonitors As Collection

' EnumDisplayMonitors 関数によって呼び出されるコールバック
#If Win64 Then
Private Function monitorEnumProc(ByVal hMonitor As LongPtr, ByVal hdcMonitor As LongPtr, ByRef lprcMonitor As RECT, ByVal dwData As LongPtr) As Long
#Else
Private Function monitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, ByRef lprcMonitor As RECT, ByVal dwData As Long) As Long
#End If
' 取得失敗とみなすのは呼び元で実施するので、ここではエラーは発生させない
On Error Resume Next
    ' Left、Top、Width、Heightの順に格納
    Call coMonitors.Add(Array(lprcMonitor.Left, lprcMonitor.Top, lprcMonitor.Right - lprcMonitor.Left, lprcMonitor.Bottom - lprcMonitor.Top))
    ' 続行
    monitorEnumProc = 1
End Function

' モニタ情報を取得
Public Function GetMonitorInfo(ByRef lngLeft As Long, ByRef lngTop As Long, ByRef lngWidth As Long, ByRef lngHeight As Long) As Boolean
On Error GoTo ErrorFunction
    
    ' メインモニタの情報で初期化
    GetMonitorInfo = True
    lngLeft = 0
    lngTop = 0
    lngWidth = GetSystemMetrics(0)
    lngHeight = GetSystemMetrics(1)
    
    Dim i As Long
    
    ' モニタ情報をすべて取得
    Set coMonitors = New Collection
    Call EnumDisplayMonitors(0, 0, AddressOf monitorEnumProc, 0)
    
    ' モニタ情報が取得できたか
    If Not coMonitors Is Nothing Then
        ' マルチモニタか
        If 1 < coMonitors.count Then
            ' 自身がいるモニタを検索
            For i = 1 To coMonitors.count
                If coMonitors(i)(0) <= Application.Left _
                    And Application.Left <= (coMonitors(i)(0) + coMonitors(i)(2)) _
                    And coMonitors(i)(1) <= Application.Top _
                    And Application.Top <= (coMonitors(i)(1) + coMonitors(i)(3)) Then
                    lngLeft = coMonitors(i)(0)
                    lngTop = coMonitors(i)(1)
                    lngWidth = coMonitors(i)(2)
                    lngHeight = coMonitors(i)(3)
                    Exit For
                End If
            Next i
        End If
    End If
    
    ' ここまで正常終了すればTrueを返す
    GetMonitorInfo = True
ErrorFunction:
End Function

例えば、Excelを今居るモニタの右上あたりに移動したいなら、こんな感じ。

Dim lngLeft As Long, lngTop As Long, lngWidth As Long, lngHeight As Long
If GetMonitorInfo(lngLeft, lngTop, lngWidth, lngHeight) Then
    ' 1ピクセル = 0.75ポイントに変換しながら右上1/4の場所に移動
    Application.Left = (lngLeft + (3 / 4 * lngWidth)) * 0.75
    Application.Top = (lngTop + (1 / 4 * lngHeight)) * 0.75
End If

他にもニッチなIT関連要素をまとめていますので、よければ一覧記事もご覧ください。

みにましあ

https://minimashia.net/it-tips

2019.12.04