サイズと容量表示できるマクロはどうすればできますか？

サイズと容量表示できるマクロはどうすればできますか？

Excel2003です。
写真を取扱うExcelの資料をいくつも作成中で、ふと気が付いたのです。
ファイルサイズが極端に大きいファイルがいくつもあることに。。。
調べてみるとどうもランダムに集めた写真のファイルサイズが
極端に大きいものもあり、バラバラなことがわかりました。
使う写真は、約4cm×5.6cm位が主なので適正なファイルサイズに
変えたいと思っています。
簡単に判断できるようにマクロを使って対象画像のサイズ/容量を表示
できるようにしたいと考えています。

識者の方、よろしくお願いします。

No.2 ベストアンサー 回答者： end-u 回答日時： 2010/10/04 19:46

ひょっとして、既にExcelに挿入した画像のサイズを調べようとされてますか？

その場合、VBAレベルでは、一旦100％にサイズを戻してあげないといけないです。
以下、ActiveWorkbookのシートをLoopして調べ、
最後に新規シートにシート名、TopLeftCellアドレス、名前、
WidthとHeightを書き出すサンプルです。

Option Explicit

Sub try()
　　Dim p　As Picture
　　Dim ws As Worksheet
　　Dim i　As Long
　　Dim v(1 To 10000, 1 To 5) '適当に。MAX10,000枚。
　　Dim ret

　　Application.ScreenUpdating = False
　　With ActiveWorkbook
　　　　For Each ws In .Worksheets
　　　　　　For Each p In ws.Pictures
　　　　　　　　i = i + 1
　　　　　　　　v(i, 1) = ws.Name
　　　　　　　　v(i, 2) = p.TopLeftCell.Address(0, 0)
　　　　　　　　v(i, 3) = p.Name
　　　　　　　　ret = fGetPicSize(p)
　　　　　　　　If IsArray(ret) Then
　　　　　　　　　　v(i, 4) = ret(0)
　　　　　　　　　　v(i, 5) = ret(1)
　　　　　　　　Else
　　　　　　　　　　v(i, 4) = "error"
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　　　.Worksheets.Add.Cells(1).Resize(i, 5).Value = v
　　End With
　　Application.ScreenUpdating = True
End Sub
'-----------------------------------------------------------
Function fGetPicSize(ByRef pic As Picture)
　　Dim x　As Single
　　Dim y　As Single
　　Dim T　As Single
　　Dim L　As Single
　　Dim W　As Single
　　Dim H　As Single
　　Dim LC As Long

　　On Error GoTo errExit
　　With pic.ShapeRange
　　　　T = .Top
　　　　L = .Left
　　　　W = .Width
　　　　H = .Height
　　　　LC = .LockAspectRatio
　　　　'画像位置によっては元サイズに戻しきれない場合の対策
　　　　.Top = 0
　　　　.Left = 0
　　　　.LockAspectRatio = msoFalse
　　　　.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
　　　　.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
　　　　'Ver2003以前のみトリミング値を考慮する
　　　　If CLng(Application.Version) < 12 Then
　　　　　　With .PictureFormat
　　　　　　　　x = .CropLeft + .CropRight
　　　　　　　　y = .CropTop + .CropBottom
　　　　　　End With
　　　　End If
　　　　x = .Width
　　　　y = .Height
　　　　.Top = T
　　　　.Left = L
　　　　.Width = W
　　　　.Height = H
　　　　.LockAspectRatio = LC
　　End With
　　fGetPicSize = Array(x, y)
errExit:
End Function

この回答へのお礼

参考式を作っていただきありがとうございました。

参考にさせていただきます。

ありがとうございました。

お礼日時：2010/10/05 21:13

No.1 回答者： nicotinism 回答日時： 2010/10/04 12:44

画像の大きさを取得する

http://officetanaka.net/excel/vba/tips/tips87.htm

ファイルのサイズを返します。
http://officetanaka.net/excel/vba/filesystemobje …

では。

この回答へのお礼

ありがとうございました。

参考にさせていただきます。

お礼日時：2010/10/05 21:06