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

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
最終更新日:2020-04-06

列幅・行高を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は、WindowsManagementInstrumentationの略になります。マイクロソフトが実装したWindowsシステムを管理するためのインターフェイスです。WMIは、Windows管理技術の中核を担っていて、ローカルコンピュータとリモートコンピュータの両方の管理に使用できます。

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技術解説」の記事

Rangeオブジェクトの論理演算(差集合と排他的論理和)
VBAで写真の撮影日時や音楽動画の長さを取得する
VBAでWindowsMediaPlayerを使い動画再生する
VBAでWEBカメラ操作する
VBAで電光掲示板を作成
ユーザーに絶対に停止させたくない場合のVBA設定
列幅・行高をDPI取得しピクセルで指定する
VBAでWMIの使い方について
アクティブシート以外の表示(Window)に関する設定
LSetとユーザー定義型のコピー(100桁の足し算)
省略可能なVariant引数の参照不可をラップ関数で利用


新着記事NEW ・・・新着記事一覧を見る

多階層フォルダ(ディレクトリ)の作成|VBAサンプル集(7月31日)
VBAのインデントについて|VBA技術解説(7月16日)
「VBA Match関数の限界」についての誤解|エクセル雑感(7月15日)
省略可能なVariant引数の参照不可をラップ関数で利用|VBA技術解説(7月12日)
100桁の正の整数値の足し算|エクセル雑感(7月9日)
LSetとユーザー定義型のコピー(100桁の足し算)|VBA技術解説(7月9日)
Variant仮引数のByRefとByValの挙動違い|エクセル雑感(7月5日)
Variant仮引数にRange.Valueを配列で渡す方法|エクセル雑感(7月5日)
Variantの数値型と文字列型の比較|エクセル雑感(7月1日)
VBAのVariant型について|VBA技術解説(6月30日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




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


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



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