画像サイズ（横x縦）の取得について

最終更新日：2016-03-19

画像サイズ（横x縦）の取得について

マクロVBAで、画像サイズ（横x縦）ピクセル数を取得する方法についての解説です、

画像は種類が多いので、全ての画像に対応しようとすると、かなり面倒になります。

このような処理は、私もたびたび使いますので、自身の覚書としての意味もあり掲載します。

まず、VBAには、LoadPictur 関数があります。

これを使ってコードを書いてみると

LoadPictur 関数


  
    
      Sub sample1()

      　　Dim pic As Object

      　　Dim pWidth As Long

      　　Dim pheight As Long

      　　Dim strFile As String

      　　strFile = Application.GetOpenFilename(FileFilter:="全てのファイル,*.*", Title:="画像ファイルを選択")

      　　If strFile = "False" Then

      　　　　Exit Sub

      　　End If

      　　Set pic = LoadPicture(strFile)

      　　pWidth = CLng(CDbl(pic.Width) * 24 / 635)

      　　pheight = CLng(CDbl(pic.Height) * 24 / 635)

      　　MsgBox "横：" & pWidth & vbLf & "縦：" & pheight

      End Sub

細部は工夫してもらうとして、概ねこのような感じになります。
これで、ほとんど問題が無さそうなのですが・・・

問題があります。
それは、
対応している画像フォーマットが、

bmp
ico
rle
wmf
emf
gif
jpg

以上に限られていることです。
これだけ対応していれば問題なさそうなのですが、
良く見て下さい・・・
png
tif
良く使われる、この二つが見当たりません。
さすがに、これでは困る場合も出てきます。

では、
png
tif
これらのサイズ取得はどうするかですが、
少し発想を変えてみましょう。
シートに画像を挿入して、そのサイズを取得すればどうでしょう。
サイズは取得できるのですが、単位が違ってしまいます。
GDIに依存するはずですが、通常の状態なら、
以下で変換できます。

AddPictureしてから取得


  
    
      Sub sample2()

　　Dim sp As Shape

　　Dim pWidth As Long

　　Dim pheight As Long

　　Dim strFile As String

　　strFile = Application.GetOpenFilename(FileFilter:="全てのファイル,*.*", Title:="画像ファイルを選択してください")

　　If strFile = "False" Then

　　　　Exit Sub

　　End If

      　　Set sp = ActiveSheet.Shapes.AddPicture( _

　　　　　　　　Filename:=strFile, _

　　　　　　　　LinkToFile:=False, _

　　　　　　　　SaveWithDocument:=True, _

　　　　　　　　Left:=0, _

　　　　　　　　Top:=0, _

　　　　　　　　Width:=0, _

　　　　　　　　Height:=0 _

　　　　　　　　)

　　With sp

　　　　.LockAspectRatio = msoTrue

　　　　.ScaleHeight 1, msoTrue

　　　　.ScaleWidth 1, msoTrue

　　　　pWidth = CLng(.Width * 4 / 3)

　　　　pheight = CLng(.Height * 4 / 3)

　　　　.Delete

　　End With

　　MsgBox "横：" & pWidth & vbLf & "縦：" & pheight

End Sub

ほとんどの場合、これで問題ないはずです。

一応、
LoadPicture関数との合わせ技という事で、以下にコードを掲載します。


  
    
      Sub sample3()

　　Dim pic As Object

　　Dim sp As Shape

　　Dim pWidth As Long

　　Dim pheight As Long

　　Dim strFile As String

　　strFile = Application.GetOpenFilename(FileFilter:="全てのファイル,*.*", Title:="画像ファイルを選択してください")

　　If strFile = "False" Then

　　　　Exit Sub

　　End If

　　Select Case Mid(strFile, InStrRev(strFile, "."))

　　　　Case ".bmp", ".ico", ".rle", ".wmf", ".emf", ".gif", ".jpg"

　　　　　　Set pic = LoadPicture(strFile)

　　　　　　pWidth = CLng(CDbl(pic.Width) * 24 / 635)

　　　　　　pheight = CLng(CDbl(pic.Height) * 24 / 635)

　　　　Case Else

　　　　　　Set sp = ActiveSheet.Shapes.AddPicture( _

　　　　　　　　　　　　Filename:=strFile, _

　　　　　　　　　　　　LinkToFile:=False, _

　　　　　　　　　　　　SaveWithDocument:=True, _

　　　　　　　　　　　　Left:=0, _

　　　　　　　　　　　　Top:=0, _

　　　　　　　　　　　　Width:=0, _

　　　　　　　　　　　　Height:=0 _

　　　　　　　　　　　　)

　　　　　　With sp

　　　　　　　　.LockAspectRatio = msoTrue

　　　　　　　　.ScaleHeight 1, msoTrue

　　　　　　　　.ScaleWidth 1, msoTrue

　　　　　　　　pWidth = CLng(.Width * 4 / 3)

　　　　　　　　pheight = CLng(.Height * 4 / 3)

　　　　　　　　.Delete

　　　　　　End With

　　End Select

　　MsgBox "横：" & pWidth & vbLf & "縦：" & pheight

End Sub

ネット検索で、画像サイズ取得でヒットするのは、
APIを使った方法が良く紹介されています。

APIを使用


  
    
      Private Declare Function GdiplusStartup Lib "gdiplus" ( _

　　　　　　　　　　　　　　　　　　　　ByRef token As Long, _

　　　　　　　　　　　　　　　　　　　　ByRef inputBuf As GdiplusStartupInput, _

　　　　　　　　　　　　　　　　　　　　ByVal outputBuf As Long) 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 GdipGetImageDimension Lib "gdiplus" ( _

      　　　　　　　　　　　　　　　　　　　　ByVal image As Long, _

      　　　　　　　　　　　　　　　　　　　　ByRef Width As Single, _

      　　　　　　　　　　　　　　　　　　　　ByRef Height As Single) As Long

Private Type GdiplusStartupInput

　　GdiplusVersion As Long

　　DebugEventCallback As Long

　　SuppressBackgroundThread As Long

　　SuppressExternalCodecs As Long

End Type


      Function サイズ取得関数(ByVal sImageFilePath As String, _

　　　　　　　　　　　　　　　　　 ByRef x As Single, _

　　　　　　　　　　　　　　　　　 ByRef y As Single) As Boolean

　　Dim uGdiStartupInput As GdiplusStartupInput

　　Dim nGdiToken As Long

　　Dim nStatus As Long

　　Dim hImage As Long

　　sample4 = False

　　x = 0: y = 0

　　uGdiStartupInput.GdiplusVersion = 1

　　nStatus = GdiplusStartup(nGdiToken, uGdiStartupInput, 0&)

　　If nStatus = 0 Then

　　　　nStatus = GdipLoadImageFromFile(ByVal StrPtr(sImageFilePath), hImage)

　　　　If nStatus = 0 Then

　　　　　　nStatus = GdipGetImageDimension(hImage, x, y)

　　　　　　If nStatus = 0 Then

　　　　　　　　sample4 = True

　　　　　　End If

　　　　End If

　　　　Call GdiplusShutdown(nGdiToken)

　　End If

End Function

このようなものです。
このコードは、ネットで公開されているものを、掲載しやすいように少し改造したもので、私のオリジナルではありません。
出所としては、あちこちに同様のコードが見受けられましたし、
そもそも、特段のオリジナリティも見受けられないので、ほぼそのまま掲載しています。

しかし、画像サイズの取得に、APIまで持ち出す必要があるのでしょうか。
先の、sample3までで、ほとんどの場合は問題ありません。
APIを使うと、64bitのExcelでは、PtrSafeの指定が必要になり、
PtrSafeを指定すると、Excel2007で動かないという問題が出てきます。

問題解決に当たっては、
まずは、より簡単な方法を選択してみて下さい