画像サイズ（横x縦）の取得について
マクロVBAで、画像サイズ（横x縦）ピクセル数を取得する方法についての解説です、
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
細部は工夫してもらうとして、概ねこのような感じになります。
これで、ほとんど問題が無さそうなのですが・・・
それは、
対応している画像フォーマットが、
ico
rle
wmf
emf
gif
jpg
これだけ対応していれば問題なさそうなのですが、
良く見て下さい・・・
png
tif
良く使われる、この二つが見当たりません。
さすがに、これでは困る場合も出てきます。
では、
png
tif
これらのサイズ取得はどうするかですが、
少し発想を変えてみましょう。
シートに画像を挿入して、そのサイズを取得すればどうでしょう。
サイズは取得できるのですが、単位が違ってしまいます。
GDIに依存するはずですが、通常の状態なら、
以下で変換できます。
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を使った方法が良く紹介されています。
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で動かないという問題が出てきます。
まずは、より簡単な方法を選択してみて下さい
同じテーマ「マクロVBA技術解説」の記事
印刷ページ設定の余白をセンチで指定する（CentimetersToPoints）
文字列としてのプロシージャー名を起動する方法（Run,OnTime）
ドキュメントの作成者を取得（GetObject,BuiltinDocumentProperties）
画像サイズ（横x縦）の取得について
文字種（ひらがな、全半角カタカナ、半角英大文字等々）の判定
オブジェクトとプロパティの真実
オブジェクト式について
オブジェクトの探索方法（オートシェイプのTextを探して）
条件付きコンパイル（32ビット64ビットの互換性）
ドキュメントプロパティ（BuiltinDocumentProperties,CustomDocumentProperties）
VBAでファイルを既定のアプリで開く方法
新着記事NEW ・・・新着記事一覧を見る
Select Caseでの短絡評価（ショートサーキット）の使い方｜VBA技術解説（1月3日）
VBA100本ノック 迷宮編：巡回セル問題｜VBA練習問題（12月31日）
VBA100本ノック 58本目：番号リストを簡潔にした文字列で返す｜VBA練習問題（12月30日）
VBA100本ノック 57本目：ファイルの更新日時｜VBA練習問題（12月29日）
VBA100本ノック 56本目：数式内の自身のシート名を消す｜VBA練習問題（12月28日）
VBA100本ノック 55本目：他ブックのマクロを起動｜VBA練習問題（12月26日）
VBA100本ノック 54本目：シートのChangeイベント｜VBA練習問題（12月25日）
VBA100本ノック 53本目：テーブルの扱いと年齢計算｜VBA練習問題（12月23日）
VBA100本ノック 52本目：複数シートの一括印刷｜VBA練習問題（12月22日）
VBA100本ノック 51本目：シート一覧と印刷ページ数｜VBA練習問題（12月21日）
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.マクロって何？VBAって何？｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
8.セルに文字を入れるとは（Range,Value）｜VBA入門
9.とにかく書いてみよう（Sub,End Sub）｜VBA入門
10.繰り返し処理（Do Loop）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBA技術解説
- 画像サイズ（横x縦）の取得について
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。