Excelに画像を貼る仕事をExcelVBAでやる

概要

Excelのシートに画像を貼るExcelマクロを作成してみた。

よくある画像貼り付けマクロだと、Shape.ScaleWidth、Shape.ScaleHeightの2つのメソッドを使って等倍で貼り付ける方法を採っているが、この方法の場合、例えばJPEG形式の画像だと画像の持っている解像度を参照して図形オブジェクトの大きさを決定してしまうため、同じ幅と高さの画像でも貼り付けられた画像の大きさが異なって見えてしまう。もちろん、画像を印刷するような場合は解像度の情報を元に大きさを決定する方が実情に適しているが、Excelに画像を貼るような場合は画面で見ることを想定しているのであり、同じ幅と高さの画像が異なる大きさに見えては困るのである。

そこで、画像の幅や高さの指定にShape.ScaleWidth、Shape.ScaleHeightのメソッドは用いず、GDI+を利用してあらかじめ画像の幅と高さをピクセル単位で取得しておいて、Shapes.AddPictureメソッドで幅や高さを指定するようにした。Shapes.AddPictureメソッドで指定する幅や高さはポイント単位なので、画面のDPIを元にピクセル単位からポイント単位に変換している。

コード

画像を貼り付ける位置がシートの左上(0, 0)で固定になっているので、連続して貼れるように貼り付け位置を算出するようにするともう少し実用的(？)になると思われる。
エラー処理は適当。

Sheet1

Option Explicit

Public Sub PastePicture()

    Dim filePath As Variant
    Dim dpiX As Integer
    Dim dpiY As Integer
    Dim width As Single
    Dim height As Single
    Dim picture As Shape

    '画像を選択させる
    filePath = Application.GetOpenFilename( _
        FileFilter:="画像ファイル,*.png;*.jpg;*.gif;*.bmp;*.tif;")
    If filePath = False Then
        Exit Sub
    End If

    'DPIの取得
    If Not GetDpi(dpiX, dpiY) Then
        MsgBox "DPIの取得に失敗"
        Exit Sub
    End If

    '画像の幅・高さの取得(ピクセル単位)
    If Not GetImageDimensionFromFile(filePath, width, height) Then
        MsgBox "画像の幅・高さの取得に失敗"
        Exit Sub
    End If

    '画像の貼り付け
    'Shapes.AddPictureの幅と高さはポイント単位で指定するので
    'ピクセル->ポイント変換する
    Set picture = ActiveSheet.Shapes.AddPicture( _
        FileName:=filePath, _
        LinkToFile:=False, SaveWithDocument:=True, _
        Left:=0, Top:=0, _
        width:=width * 72 / dpiX, height:=height * 72 / dpiY)

    Set picture = Nothing
End Sub

標準モジュール

Option Explicit

'GDI+ API定義
#If VBA7 And Win64 Then

Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" ( _
    ByRef token As LongPtr, _
    ByRef inputbuf As GdiplusStartupInput, _
    Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" ( _
    ByVal token As LongPtr)
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "GDIPlus" ( _
    ByVal FileName As LongPtr, _
    ByRef image As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" ( _
    ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageDimension Lib "GDIPlus" ( _
    ByVal image As LongPtr, _
    ByRef width As Single, _
    ByRef height As Single) As Long

#Else

Private Declare Function GdiplusStartup Lib "GDIPlus" ( _
    ByRef token As Long, _
    ByRef inputbuf As GdiplusStartupInput, _
    Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "GDIPlus" ( _
    ByVal token As Long)
Private Declare Function GdipLoadImageFromFile Lib "GDIPlus" ( _
    ByVal FileName As Long, _
    ByRef image As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _
    ByVal image As Long) As Long
Private Declare Function GdipGetImageDimension Lib "GDIPlus" ( _
    ByVal image As Long, _
    ByRef width As Single, _
    ByRef height As Single) As Long

#End If

'Windows API定義
#If VBA7 And Win64 Then

Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal hdc As Long) As Long

#Else

Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal hdc As Long) As Long

#End If

'GDI+用ユーザ定義型
#If VBA7 And Win64 Then

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

#Else

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

#End If

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

'DPIの取得
Public Function GetDpi(ByRef dpiX As Integer, ByRef dpiY As Integer) As Boolean

    Dim hdc As Long

    hdc = GetDC(Application.hwnd)
    If hdc Then
        dpiX = GetDeviceCaps(hdc, LOGPIXELSX)
        dpiY = GetDeviceCaps(hdc, LOGPIXELSY)

        GetDpi = True
        Call ReleaseDC(Application.hwnd, hdc)
    End If

End Function

'画像の幅と高さをピクセル単位で取得する
'対応フォーマット:GDI+準拠(BMP, JPEG, GIF, TIFF, PNG)
Public Function GetImageDimensionFromFile( _
    ByVal filePath As String, ByRef width As Single, ByRef height As Single) As Boolean

    Dim uGdiStartupInput As GdiplusStartupInput
#If VBA7 And Win64 Then
    Dim nGdiToken As LongPtr
    Dim hImage As LongPtr
#Else
    Dim nGdiToken As Long
    Dim hImage As Long
#End If

    uGdiStartupInput.GdiplusVersion = 1

    If GdiplusStartup(nGdiToken, uGdiStartupInput) = 0 Then
        If GdipLoadImageFromFile(ByVal StrPtr(filePath), hImage) = 0 Then
            If GdipGetImageDimension(hImage, width, height) = 0 Then
                GetImageDimensionFromFile = True
            End If
            If GdipDisposeImage(hImage) <> 0 Then
                MsgBox "メモリの解放に失敗"
            End If
        End If
        Call GdiplusShutdown(nGdiToken)
    End If

End Function

Excelの画像挿入について

Shape.ScaleWidth、Shape.ScaleHeightメソッドを使って画像を等倍で貼り付けるコード片は以下のような感じになる。

Set picture = ActiveSheet.Shapes.AddPicture( _
    FileName:=filePath, _
    LinkToFile:=False, SaveWithDocument:=True, _
    Left:=0, Top:=0, _
    width:=0, height:=0)

With picture
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
End With

Set picture = Nothing

この方法だと、Excelでメニューから画像を挿入したときと同じ大きさになるようだ。

普通にExcelで画像を挿入すると、例えば幅・高さがともに320pixelで解像度が水平・垂直方向ともに360dpiのJPEG形式の画像の場合、幅・高さがともに2.26cmの図形オブジェクトになる。

どういう計算でこの大きさになっているかというと、
320(pixel) / 360(dpi) * 2.54(cm) = 2.2577777...(cm) ≒ 2.26(cm)
という計算式によるようだ。

Wikipediaより

pixelはコンピュータで画像を扱うときの、色情報(色調や階調)を持つ最小単位、最小要素。しばしばピクセルと同一の言葉として使われるドットとは、後者が単なる物理的な点情報であることで区別される。
dpiとはdots per inchの略で、ドット密度の単位である。1インチの幅の中にどれだけのドットを表現できるかを表す。

つまり、1inch中に360個点(ドット)を打てる密度で320個の点を打つと何inch必要かを計算すれば良い。後はinchからcmへの単位の換算(1inch = 2.54cm)をしてやれば算出できる。
なお、解像度の情報を持たないBMP形式等の画像の場合、Excelの内部では72dpiとなっているようで、72dpiの画像として計算すれば良い。