ExcelVBAで画像のサイズを調べるマクロを作ろうと思っています

質問

VBAはほんの少しだけ触れた事のある初心者です。

全シートを走査して、シート上にある特定のサイズ以上の画像ファイルを探し、それらの画像ファイルを指摘（こことここの画像がサイズオーバーです！　など）するアドインを作りたいと思っています。

さらにに、できるようであれば指摘後に画像をリサイズして張りなおすような事もしたいです。

作るに当たって、何から手を付けて良いかさっぱりわかりません。
使用する関数や、サンプルなど、何でも良いのでアドバイスをお願いします。

回答No.3

mitarashi · ベストアンサー

#2です。EnhancedMetaFileのお勉強をしていました。
ワークシートに貼り付けた画像を選択した状態で、下記のコードを実行すると、オリジナルのピクセル数が取得できると思います。
・APIの定数、関数等の入手先－必要なものをセットしないと動きません。長いので割愛します。
http://homepage2.nifty.com/nonnon/Win32Api/
・最もキーとなった、参考URL
http://nienie.com/~masapico/api_GetEnhMetaFileBits.html
Sub getPixelCount()
Dim SrcData() As Byte
Dim hSrcMetaFile As Long
Dim BufSize As Long
Dim SrcIdx As Long
Dim RecordHeader As emr
Dim strechDibRecord As EMRSTRETCHDIBITS

Selection.Copy
If OpenClipboard(0) Then
hSrcMetaFile = GetClipboardData(CF_ENHMETAFILE)
hSrcMetaFile = CopyEnhMetaFile(hSrcMetaFile, vbNullString)
CloseClipboard
End If
If hSrcMetaFile = 0 Then Exit Sub
BufSize = GetEnhMetaFileBits(hSrcMetaFile, ByVal 0, ByVal 0)
ReDim SrcData(BufSize)
BufSize = GetEnhMetaFileBits(hSrcMetaFile, BufSize, SrcData(0))
If BufSize = 0 Then Exit Sub
SrcIdx = 0
While SrcIdx < BufSize
MoveMemory RecordHeader, SrcData(SrcIdx), Len(RecordHeader)
If RecordHeader.iType = EMR_STRETCHDIBITS Then
MoveMemory strechDibRecord, SrcData(SrcIdx), Len(strechDibRecord)
End If
SrcIdx = SrcIdx + RecordHeader.nSize
Wend

DeleteEnhMetaFile hSrcMetaFile
With strechDibRecord
Debug.Print ".cxSrc - ", .cxSrc
Debug.Print ".cySrc - ", .cySrc
End With
End Sub

Public Function EnumFunc( _
ByVal hdc As Long, _
ByVal pHandles As Long, _
ByVal pRecord As Long, _
ByVal HandleNum As Long, _
ByVal pData As Long) As Long

Dim eh As ENHMETARECORD

RtlMoveMemory VarPtr(eh), pRecord, Len(eh)
EnumFunc = 1
End Function

回答No.2

mitarashi

シートに貼り付けた画像は、元画像のサイズや、解像度dpiの情報を保持している様ですが、
ローカルウィンドウを表示させてメンバーを眺めていても、それらしい物が見つかりません。
ご存じの方がいたら、自分も是非知りたいです。
ベタな方法ですが、解像度96dpi決め打ちで、下記により画像のサイズ（ピクセル数）が取得できるかも。
（クリップボードから貼り付けたり、解像度情報の無いファイルだと、96dpiと見なされる様です）
なお、VBAによる画像のリサイズについては、下記に回答した例があります。
http://okwave.jp/qa/q5647625.html
xl2000のコードです。他の環境で動かない場合はあしからず。

Type shapeSize
Width As Long
Height As Long
End Type

Sub test()
Dim shp As Shape
Dim shpSize As shapeSize

For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shpSize = test2(shp)
Debug.Print shpSize.Width, shpSize.Height
End If
Next shp
End Sub

Function test2(shp As Shape) As shapeSize
Dim originalSize As shapeSize

Application.ScreenUpdating = False
originalSize.Width = shp.Width
originalSize.Height = shp.Height
shp.ScaleWidth 1, msoTrue
shp.ScaleHeight 1, msoTrue
test2.Width = shp.Width * 96 / 72
test2.Height = shp.Height * 96 / 72
shp.Width = originalSize.Width
shp.Height = originalSize.Height
Application.ScreenUpdating = True
End Function

回答No.1

hige_082

やりたいのは分りますが
＞VBAはほんの少しだけ触れた事のある初心者です。
では・・・
十分理解してからでないと難しいと思いますよ

まずは、この辺から
Sub Macro1()
Dim ws As Worksheet
Dim i
For Each ws In Worksheets
With ws
For i = 1 To .Shapes.Count
With .Shapes(i)
MsgBox "SheetName = " & ActiveSheet.Name & vbCrLf & _
"ShapeName = " & .Name & vbCrLf & _
"ShapeHeight = " & .Height & vbCrLf & _
"ShapeWidth = " & .Width
End With
Next i
End With
Next ws
End Sub

参考まで

補足

ご回答ありがとうございます。
この程度でしたら理解できます。

すみません、言い方が悪かったです。
画像の縦横のサイズではなく、画像自体のファイルサイズを取得して警告を出したいなと考えています。
メッセージボックスの出し方やループに関しては参考にさせていただきます。