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

DPI値っていうと堅苦しいけど、要は、ディスプレイ設定の「テキスト、アプリ、その他の項目のサイズ」ってやつが100%かどうかを知りたいお年頃です。
いくつか方法があるのでつらつらと説明していきます。

GetDpiForMonitorで取得する

このコードを書いたExcelブックを起動した状態のまま、テキストサイズを変更しても最新値は取れないので、Excelブックの再起動が必要です。

Option Explicit

Private Const S_OK = 0

Private Enum MONITOR_DPI_TYPE
  MDT_EFFECTIVE_DPI = 0
  MDT_ANGULAR_DPI = 1
  MDT_RAW_DPI = 2
  MDT_DEFAULT = MDT_EFFECTIVE_DPI
End Enum

Private Enum MONITOR_DEFAULTS
    MONITOR_DEFAULTTONULL = &H0&
    MONITOR_DEFAULTTOPRIMARY = &H1&
    MONITOR_DEFAULTTONEAREST = &H2&
End Enum

#If Win64 Then
    Private Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
    Private Declare PtrSafe Function GetDpiForMonitor Lib "shcore" ( _
        ByVal hMonitor As Long, ByVal dpiType As MONITOR_DPI_TYPE, _
        ByRef dpiX As Long, ByRef dpiY As Long) As Long
    Private Declare PtrSafe Function MonitorFromWindow Lib "User32" ( _
        ByVal Hwnd As Long, ByVal dwFlags As MONITOR_DEFAULTS) As Long
#Else
    Private Declare Function GetDesktopWindow Lib "User32" () As Long
    Private Declare Function GetDpiForMonitor Lib "shcore" ( _
        ByVal hMonitor As Long, ByVal dpiType As MONITOR_DPI_TYPE, _
        ByRef dpiX As Long, ByRef dpiY As Long) As Long
    Private Declare Function MonitorFromWindow Lib "User32" ( _
        ByVal Hwnd As Long, ByVal dwFlags As MONITOR_DEFAULTS) As Long
#End If

Private Sub cmdGetDpi_Click()
    Dim dpiX As Long
    Dim dpiY As Long

    If GetDpiForMonitor(MonitorFromWindow(GetDesktopWindow(), MONITOR_DEFAULTTONEAREST), _
                        MDT_DEFAULT, dpiX, dpiY) = S_OK Then
        Debug.Print "dpiX = " & CStr(dpiX) & " (" & CStr(CSng(dpiX * 100) / 96) & "%)" & vbNewLine _
                   & "dpiY = " & CStr(dpiY) & " (" & CStr(CSng(dpiY * 100) / 96) & "%)"
    End If
End Sub

Twipから求める

Microsoft独自単位のTwipは96dpi(100%)であれば15Twip=1pixelであることを利用して求めます。
以前は変更後にサインアウトしないと最新の値が取れなかったのですが、最近は取れるようになった？
ただ、このコードを書いたExcelブックも、起動した状態のままテキストサイズを変更しても最新値は取れないので、Excelブックの再起動が必要です。

Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
    Private Declare PtrSafe Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hdc As Long) As Long
#Else
    Private Declare Function GetDesktopWindow Lib "User32" () As Long
    Private Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hdc As Long) As Long
#End If

Sub test()
    Dim hWndDesk As Long        ' デスクトップのハンドル
    Dim hDCDesk As Long         ' デスクトップのDC
    Dim nPix As Long            ' 画面の水平方向での論理インチ当たりのピクセル数
    Dim nTwip As Long           ' ピクセルのTwip変換結果
    
    Const KLNG_LOGPIXELSX = 88  ' GetDeviceCapsに渡す引数
    Const KLNG_PIX = 1440       ' 1 論理インチは 1440twip
    Const KLNG_TWIP = 15        ' Microsoft Windowsの標準のシステム解像度では15Twipsで1ピクセル
    
    ' 画面の水平方向での論理インチ当たりのピクセル数を取得
    hWndDesk = GetDesktopWindow()
    hDCDesk = GetDC(hWndDesk)
    nPix = GetDeviceCaps(hDCDesk, KLNG_LOGPIXELSX)
    
    ' ピクセル->Twipに変換
    nTwip = KLNG_PIX / nPix
    
    ' 15なら100%
    Debug.Print "nTwip = " & nTwip
    
    Call ReleaseDC(hWndDesk, hDCDesk)
End Sub

Win32_DisplayConfigurationはダメっぽい？

150%にしてても96dpi(100%)が取得されちゃったんですが、なんで？？
教えてすごい人！

Option Explicit

Sub test()
    Dim objClassSet As Object
    Dim objClass As Object
    
    Set objClassSet = CreateObject("WbemScripting.SWbemLocator") _
                        .ConnectServer _
                        .ExecQuery("Select * From Win32_DisplayConfiguration")
    For Each objClass In objClassSet
        Debug.Print "LogPixels = " & CStr(objClass.LogPixels)
    Next objClass
    
    Set objClassSet = Nothing
    Set objClass = Nothing
End Sub

レジストリから取得する

Windows8.1ならHKCU \ Control Panel \ Desktop \ logpixelsで取得できるってMicrosoft様がおっしゃるけれど、Windows10にはデフォルトで存在しなかった。
Win8DpiScalingっていうキナ臭いキーはありましたが、やりたいことから外れすぎてるので調査は中断。

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

みにましあ

 

https://minimashia.net/it-tips

2019.12.04

IT tips

ITカテゴリーのページじゃ探しにくい方向けにまとめた記事です。ニッチな情報ばかりなので、需要あるのか疑問だわぁ…。Windowsスリープ中のWindowsパソコンでもUSB充電する方法Windows10（1909）のダウンロードフォルダの表示をもとに戻す自宅勤務でネットワーク設定の切り替えをする 自宅勤務でスピーカー設定の切り替えをするWindows11対応端末かどうか調べるWindows10の大型Update（21H1）に失敗する場合の対処法いまさらWindows7を用意して.NET Framework4.6.2をインストールしてみたWindows11を触ってみた感想@2022年4月同じ...