pptやwordに貼り付けた図が重い場合

いくつもの図が貼られているpptやwordのファイルが重い場合の話なのです．このファイルを軽くしようと，どの図が重いのかを探し出したい時があります．一個一個消して，プロパティでファイルの重さを調べて，やっと重い図を見つけて軽い形式に直す，というようなことをしています．もっと簡単な方法はないでしょうか．毎回プロパティーを表示させるだけでも結構面倒で，どこかに今のファイル容量をリアルタイム表示させておくだけでも助かるのですが．または，各図がどのくらいの容量なのかが分かるといいのですが．どうでしょうか．宜しくお願いします．

No.5 回答者： noname#35217 回答日時： 2007/07/05 12:59

#4です。

自分のメモのために。
pptの開いてるページのshapeを調べて、容量が大きそうなshapeを新規ページに貼り付けるマクロを作りました。#4と併せると大きなshapeが特定できると思います。
あと、「高速保存」のチェックははずす。図の圧縮オプションで、対象：「ドキュメント内の全ての図」、解像度：「Web/画面」が選べます。

Sub pptShapeAna()
'開いてるページのshapeを調べ、新規ページに貼り付ける
Dim tmpPresen, orgPresen As Presentation
Dim c, CurrSlide As Long
Dim sp As Shape
Dim str, tmpName As String
Dim n, x
Set orgPresen = ActivePresentation
CurrSlide = ActiveWindow.Selection.SlideRange.SlideNumber
Set tmpPresen = Presentations.Add(WithWindow:=msoFalse)
c = 0: tmpName = "d:\Temp\test_pptShapeAna.ppt"
For n = 1 To orgPresen.Slides(CurrSlide).Shapes.Count
Set sp = orgPresen.Slides(CurrSlide).Shapes(n)
sp.Select: x = 0
Select Case sp.Type
Case msoAutoShape: str = "オートシェイプ"
Case msoGroup: str = "グループ": x = 1
Case msoEmbeddedOLEObject: str = "OLE": x = 1
Case msoLine: str = "ライン"
Case msoLinkedPicture: str = "画像": x = 1
Case msoPlaceholder: str = "プレースホルダ"
Case msoTextEffect: str = "WardArt"
Case msoMedia: str = "メディア": x = 1
Case msoTextBox: str = "テキストボックス"
Case msoTable: str = "テーブル": x = 1
Case Else: str = "その他"
End Select
MsgBox ("番号：" & n & "　タイプ：" & sp.Type & "　" & str)
If x > 0 Then
sp.Copy: c = c + 1
tmpPresen.Slides.Add Index:=c, Layout:=ppLayoutBlank
tmpPresen.Slides(c).Shapes.Paste
End If
Next n
tmpPresen.SaveAs tmpName
tmpPresen.Close
End Sub

No.4 回答者： noname#35217 回答日時： 2007/07/04 17:01

私も同じようなことで悩むことがあります。

図ごとではなくてページごとですが、pptの容量を表示するマクロはどうでしょう？異常に大きいページを絞れるかと。
ドラッグ＆ドロップで図を貼ると圧縮が効かない場合があるようですので、いったんカットしてから形式を選択して貼り付けると#3さんの方法で小さくなるかもしれません。

Sub pptPageSize()
Dim tmpPresen, orgPresen As Presentation
Dim s, tmpName As String
Dim fso, f, n, kb
Set orgPresen = ActivePresentation
Set tmpPresen = Presentations.Add
tmpName = "D:\Temp\test_pptPageSize.ppt"
Set fso = CreateObject("Scripting.FileSystemObject")
For n = 1 To orgPresen.Slides.Count
orgPresen.Slides(n).Copy
tmpPresen.Slides.Paste
tmpPresen.SaveAs tmpName
Set f = fso.GetFile(tmpName)
kb = f.Size / 1024
s = s & "p." & n & " : " & Format(kb, "####") & vbCrLf
tmpPresen.Slides(1).Delete
Next
MsgBox s, 0, "ページのサイズ(kbyte)"
tmpPresen.SaveAs FileName:=tmpName
tmpPresen.Close
fso.GetFile(tmpName).Delete
Set fso = Nothing
End Sub

No.3 回答者： noname#176215 回答日時： 2007/07/02 12:16

[図]ツールバーを表示させて [図の圧縮]

→[ドキュメント内のすべての図]を選択した状態で
解像度を変更して[OK]

で一括に圧縮されませんか？

No.2 回答者： Kindon98 回答日時： 2007/07/02 08:56

市販ソフトを使うならNXPowerLite

http://www.nxpowerlite.jp/

アバウトでよければ、こういったサードパーティのソフトを使わず、標準機能で圧縮。
PowerPointで例にとると。保存で左上の「ツール」から画像の圧縮。
200dpiしか設定できませんが、それで十分なら。

こんな方法も

http://office.microsoft.com/ja-jp/powerpoint/HA0 …

No.1 回答者： esupuresso 回答日時： 2007/07/02 02:26

一度クリーンアップをかけてみてはいかがでしょう？