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

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
公開日: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での短絡評価(ショートサーキット)の使い方


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

ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.並べ替え(Sort)|VBA入門
8.条件分岐(IF)|VBA入門
9.セルのクリア(Clear,ClearContents)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




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


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



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