列幅・行高をDPI取得しピクセルで指定する

公開日：2020-04-06　最終更新日：2021-02-04

列幅・行高をDPI取得しピクセルで指定する

VBAでは、ワークシートの列幅は文字数、行高はポイントで設定します。
これらでの指定は便利な時もありますが、VBAで設定する場合に不便になる事も多くあります。

そもそも、列幅と行高が別々の単位になっているので設定しづらいのです。
さらにPC環境によってこの数値が変わってしまう為、VBAで列幅・行高を変更する時の悩みの種になる事が多々あります。

そこで、列幅・行高をピクセルで指定できるようにします。
これには、PC環境（DPIの違い）に合わせてピクセルをポイントに変換し、さらに列幅では文字数に変換する必要があります。

列幅・行高をピクセルで指定するVBA


  
    
      Option Explicit


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


'GetDeviceCapsのnIndex設定値

Private Const LOGPIXELSX As Long = 88

Private Const LOGPIXELSY As Long = 90


'行高をピクセルで設定

Sub RowHeightPixcel(ByVal aRange As Range, aPixcel As Long)

　　aRange.EntireRow.RowHeight = PixcelToPoint(aPixcel)

End Sub


'列幅をピクセルで指定

Sub ColumnWidthPixcel(ByVal aRange As Range, aPixcel As Long)

　　Dim colRange As Range, colRange1c As Range

　　Set colRange = aRange.EntireColumn

　　Set colRange1c = colRange.Columns(1)

　　

　　Dim colWidth As Single

　　Dim inc As Single, iSign As Integer, iSign2 As Integer

　　

　　'先頭列のみ大雑把に列幅を設定

　　colWidth = WorksheetFunction.Round(aPixcel * 0.1 * GetDpi / LogicalPixcel, 1)

　　colRange1c.ColumnWidth = colWidth

　　

　　'目標値の方向を1の±符号で

　　iSign = IIf(PointToPixcel(colRange1c.Width) > aPixcel, -1, 1)

　　

　　'0.1単位で増減させて一致するまでループ

　　Do

　　　　'デバッグ込みで現在の幅を出力

　　　　Debug.Print PointToPixcel(colRange1c.Width)

　　　　

      　　　　'先頭列が目標値なら全列設定して終了

　　　　If PointToPixcel(colRange1c.Width) = aPixcel Then

　　　　　　Call CopyColumnWidth(colRange, colRange1c)

　　　　　　Exit Sub

　　　　End If

　　　　

      　　　　'先頭列が最大値なら全列設定して終了

　　　　If colRange1c.ColumnWidth = 255 Then

　　　　　　Call CopyColumnWidth(colRange, colRange1c)

　　　　　　Exit Sub

　　　　End If

　　　　

　　　　'0.1単位で増減させる

　　　　colWidth = WorksheetFunction.Round(colWidth + (0.1 * iSign), 1)

　　　　

　　　　'行き過ぎてしまったときの永久ループ対策

　　　　iSign2 = IIf(PointToPixcel(colRange1c.Width) > aPixcel, -1, 1)

　　　　If iSign <> iSign2 Then

　　　　　　MsgBox "ダメ、おかしい"

　　　　　　Exit Sub

　　　　End If

　　　　

　　　　'先頭列のみ列幅を変更

　　　　colRange1c.ColumnWidth = colWidth

　　Loop

End Sub


Sub CopyColumnWidth(ByVal aRng1 As Range, ByVal aRng2 As Range)

　　aRng1.ColumnWidth = aRng2.ColumnWidth

End Sub


'ポイントをピクセルに変換

Function PointToPixcel(ByVal aPoint As Single) As Long

　　PointToPixcel = aPoint / 72 * LogicalPixcel

End Function


'ピクセルをポイントに変換

Function PixcelToPoint(ByVal aPixcel As Long) As Single

　　PixcelToPoint = aPixcel * 72 / LogicalPixcel

End Function


'DPIを取得：ディスプレイの拡大率込

Public Function LogicalPixcel() As Long

　　'デスクトップのウィンドウハンドルを取得

　　Dim hWndDesk As Long

　　hWndDesk = GetDesktopWindow()

　　

　　'デバイスコンテキストを取得

　　Dim hDCDesk As Long

　　hDCDesk = GetDC(hWndDesk)

　　

　　'デバイス固有情報を取得

　　LogicalPixcel = GetDeviceCaps(hDCDesk, LOGPIXELSX)

　　

      　　'デバイスコンテキストを解放

　　Call ReleaseDC(hWndDesk, hDCDesk)

End Function


'DPIを取得：標準

Function GetDpi() As Long

　　Const cSql As String = "Select * From Win32_DisplayConfiguration"

　　With CreateObject("WbemScripting.SWbemLocator").ConnectServer

　　　　GetDpi = .ExecQuery(cSql).ItemIndex(0).LogPixels

　　End With

End Function

列幅・行高をピクセルで指定するVBAの使い方と解説

使い方

アクティブシートの全セルの列幅・行高を20ピクセルに設定します。
いわゆる方眼紙ですね。
この際、方眼紙の是非については考えないことにしましょう。


  
    
      Sub sample()

      　　Dim myRange As Range

      　　Set myRange = ActiveSheet.Cells

      　　Application.ScreenUpdating = False

      　　Call ColumnWidthPixcel(myRange, 20)

      　　Call RowHeightPixcel(myRange, 20)

      　　Application.ScreenUpdating = True

      End Sub

解説

まず、以下の関数Functionが肝になります。

ポイントをピクセルに変換

Function PointToPixcel(ByVal aPoint As Single) As Long
10 → 17

ピクセルをポイントに変換

Function PixcelToPoint(ByVal aPixcel As Long) As Single
17 → 10.2

DPIを取得：ディスプレイの拡大率込

Public Function LogicalPixcel() As Long
100% → 96
125% → 120

DPIを取得：標準

WMIを使用しています。

・WMIを調べるときの推奨サイト・VBAでのWMI使用方法・WMIにはどんなものがあるのか

Function GetDpi() As Long
通常は常に96

上記関数を使って、以下の処理をしています。

・先頭列のみ大雑把に列幅を設定
・0.1単位で増減させて一致するまでループ
・目標値または最大値になったら全列幅設定して終了

このループ処理が多少不自然な流れになっています。
それは、0.1単位に増減していく処理を一方方向のみに進むようにしているためです。
ループ前に増減の方向を決定して、万一行き過ぎてしまった場合は停止させています。
ただし、本当に万一の為に入れたものになります。
列幅のピクセル数は、整数の1きざみでになっているので、整数値で一致しないことは基本的にはないはずです。

DPIの取得

画面拡大率に伴う理論解像度の取得はAPIを使用しています。
これについては、VBAを参照してください。
APIの詳細については、ネットで調べればそれなりの情報が出てくるはずです。

当初はAPIではなく、WMIで取得しようと、以下のような関数Functiomを作成しました。


  
    
      'DPIを取得：ディスプレイの拡大率込

      Function LogicalPixcel() As Long

　　Const cSql As String = "Select * From Win32_DesktopMonitor"

　　With CreateObject("WbemScripting.SWbemLocator").ConnectServer

　　　　GetMonitor = .ExecQuery(cSql).ItemIndex(0).PixelsPerXLogicalInch

　　End With

      End Function

この関数は、拡大率125%なら120（96*1.25）を返します。
本来はこれで良いはずだと思ったのですが・・・

確認してみた限りでは拡大率を変更してもこの数値が変化しませんでした。
125%で当初から使用しているPCは120のまま、
100%で当初から使用しているPCは96のまま、
Windowsの設定変更後に、PC再起動しても反映されませんでした。
この理由は不明です。
何かの原因があるのか、対処方法があるのか等々、詳細の調査はしていません。
その代わりとして、APIを使用することに変更しました。
このAPIは、設定を変更すればエクセルを再起動せずとも正しい値を取得できています。

ただし、これらの確認実行したPCはWindows10だけになります。
Windows10 HomeとProの2台で確認したもので、他のWindowsバージョンについては未確認です。

同じテーマ「マクロVBA技術解説」の記事

VBAでWEBカメラ操作する
 VBAで電光掲示板を作成
 ユーザーに絶対に停止させたくない場合のVBA設定
列幅・行高をDPI取得しピクセルで指定する
VBAでWMIの使い方について
 アクティブシート以外のWindowを設定できるWorksheetView
LSetとユーザー定義型のコピー（100桁の足し算）
省略可能なVariant引数の参照不可をラップ関数で利用
 ブックのいろいろな開き方（GetObject,参照設定,アドイン）
入力規則への貼り付けを禁止する
 Select Caseでの短絡評価（ショートサーキット）の使い方

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.メッセージボックス(MsgBox関数)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.ブック・シートの選択（Select,Activate）｜VBA入門
10.条件分岐（Select Case）｜VBA入門

ホーム
マクロVBA応用編
マクロVBA技術解説
列幅・行高をDPI取得しピクセルで指定する

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA技術解説
列幅・行高をDPI取得しピクセルで指定する