VBA技術解説
画像サイズ（横x縦）の取得について

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
最終更新日：2021-03-13

画像サイズ（横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 sample4(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で動かないという問題が出てきます。
後日追記 ・・・ 64bit版のVBAを掲載しておきます。

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" ( _
　　　　　　　　　　　　　　　　　　　　ByRef token As LongPtr, _
　　　　　　　　　　　　　　　　　　　　ByRef inputBuf As GdiplusStartupInput, _
　　　　　　　　　　　　　　　　　　　　ByVal outputBuf As Long) 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 GdipGetImageDimension Lib "gdiplus" ( _
　　　　　　　　　　　　　　　　　　　　ByVal image As LongPtr, _
　　　　　　　　　　　　　　　　　　　　ByRef Width As Single, _
　　　　　　　　　　　　　　　　　　　　ByRef Height As Single) As Long
Private Type GdiplusStartupInput
　　GdiplusVersion As Long
　　DebugEventCallback As LongPtr
　　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 LongPtr
　　Dim nStatus As Long
　　Dim hImage As LongPtr
　　画像サイズ取得 = 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
　　　　　　　　画像サイズ取得 = True
　　　　　　End If
　　　　End If
　　　　Call GdiplusShutdown(nGdiToken)
　　End If
End Function



同じテーマ「マクロVBA技術解説」の記事

印刷ページ設定の余白をセンチで指定する（CentimetersToPoints）
文字列としてのプロシージャー名を起動する方法（Run,OnTime）
ドキュメントの作成者を取得（GetObject,BuiltinDocumentProperties）
画像サイズ（横x縦）の取得について
文字種（ひらがな、全半角カタカナ、半角英大文字等々）の判定
オブジェクトとプロパティの真実
オブジェクト式について
オブジェクトの探索方法（オートシェイプのTextを探して）
条件付きコンパイル（32ビット64ビットの互換性）
ドキュメントプロパティ（BuiltinDocumentProperties,CustomDocumentProperties）
VBAでファイルを既定のアプリで開く方法


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

PropertyのSetはLetでも良い｜VBA技術解説(2021-03-31)
エクセル麻雀ミニゲーム｜VBAサンプル集(2021-03-09)
VBA100本ノック 100本目：WEBから100本ノックのリストを取得｜VBA練習問題(2021-03-03)
VBA100本ノック 魔球編：2桁の最小公倍数｜VBA練習問題(2021-02-02)
Select Caseでの短絡評価（ショートサーキット）の使い方｜VBA技術解説(2021-01-03)
VBA100本ノック 迷宮編：巡回セル問題｜VBA練習問題(2020-12-31)
VBA100本ノック 魔球編：閉領域の塗り潰し｜VBA練習問題(2020-12-16)
VBA100本ノック 魔球編：組み合わせ問題｜VBA練習問題(2020-12-02)
将棋とプログラミングについて～そこには型がある～｜エクセル雑感(2020-11-22)
VBA100本ノック 1本目：セルのコピー｜VBA練習問題(2020-10-19)


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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.マクロって何？VBAって何？｜VBA入門
5.Excelショートカットキー一覧｜Excelリファレンス
6.繰り返し処理（For Next)｜VBA入門
7.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
8.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
9.セルに文字を入れるとは（Range,Value）｜VBA入門
10.とにかく書いてみよう（Sub,End Sub）｜VBA入門



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


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

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク

↑