ExcelVBA技 全般 E13M012

E13M012 (Excel2000～2013)
図形描画の長さ単位にcm及びピクセルを用いる

VBAでは図形描画の長さ単位はポイント(pt)が用いられています。
従って、他の単位で設定するには、ポイント単位に変換する必要があります。
長さをcm単位で指定する場合の変換には Application.CentimetersToPoints メソッド が用意されています。
また、長さをピクセル(px)単位で設定する関数を併せて示します 

'標準モジュール
Option Explicit
Option Private Module
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
  (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" _
  (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long
#Else
Private Declare Function GetDeviceCaps Lib "gdi32" _
  (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Sub ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long)
#End If

'kpx2pt関数
'ピクセル単位の数値をポイント単位に変換
'px　 :変換の対象となるピクセル単位の数値
'戻り値:ポイント単位の数値
Function kpx2pt(px As Long, Optional vertical As Boolean) As Double
  Dim hDc
  Static xx#, yy#
  If xx = 0 Then
    hDc = GetDC(0)
    xx = 72 / GetDeviceCaps(hDc, LOGPIXELSX) 'xDPI
    yy = 72 / GetDeviceCaps(hDc, LOGPIXELSY) 'yDPI
    ReleaseDC Application.hWnd, hDc
  End If
  kpx2pt = IIf(vertical, px * yy, px * xx) '0.6' 0.75
End Function

'kcm2pt関数
'センチメートル単位の数値をポイント単位に変換
'cm　 :変換の対象となるセンチメートル単位の数値
'戻り値:ポイント単位の数値
Function kcm2pt(cm As Double) As Double
  kcm2pt = Application.CentimetersToPoints(cm)
End Function

'kpx2pt関数の使用例
'アクティブの図形を幅をピクセル単位で設定する
Sub example_kpx2pt()
  If VarType(Selection) <> vbObject Then Exit Sub
  With Selection.ShapeRange
    .Width = kpx2pt(150) '幅を150pxに
    .Height = kpx2pt(150, True) '高さを150pxに
  End With
End Sub

'kcm2pt関数の使用例
'アクティブの図形を幅をcm単位で設定する 図形を選択して実行
Sub example_kcm2pt()
  If VarType(Selection) <> vbObject Then Exit Sub '図形ではない
  With Selection.ShapeRange
    .Width = kcm2pt(5.5)  '幅を5.5cmに
    .Height = kcm2pt(5.5) '高さを5.5cmに
  End With
End Sub