PowerPointのVBAで、図形を縮小後、画質を落とさずに出力する方法

質問

PowerPointのVBAで、スライド上の図形のサイズを縮小した後、この図形をjpg画像として保存したいです。

オペレーションはこんな感じです↓
図形縮小→図形を選択→右クリック→[図として保存]→JPGファイル名で保存

上記操作を「マクロの記録」で記録したものを実行すると、スライド全体が保存されてしまいます。
また、マクロで.ShapeRange.Exportで画像出力すると、画質が荒くなって出力されます。

画質を落とさず、図形をjpgとして保存する方法はないでしょうか。
よろしくお願い致します。

以下が、現状の私のプログラムです。
Sub Macro()

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="C:\aaaa.JPG", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=-119, Top:=-89, Width:=960, Height:=720).Select
ActiveWindow.LargeScroll ToRight:=1
With ActiveWindow.Selection.ShapeRange
.ScaleWidth 0.25, msoFalse, msoScaleFromTopLeft
.ScaleHeight 0.25, msoFalse, msoScaleFromTopLeft
End With
With ActiveWindow.Selection.ShapeRange
.IncrementLeft 219.12
.IncrementTop 416.75
End With
ActiveWindow.Selection.ShapeRange.Select

'これだと画質が落ちます。↓
Call ActiveWindow.Selection.ShapeRange.Export("C:\\bbb.jpg", ppSaveAsJPG)

'これだとスライド全体が保存されます。↓
' ActivePresentation.SaveAs FileName:="C:\bbb.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse

End Sub

回答No.2

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

> PP単体では難しいようでしたら、他の方法に変えたいと思います。

そうアッサリと引き下がらないで頑張ってみましょうよ(;´・ω・`)σ

「専用ソフトではなく、あえて Office ツールでやってみる」という精神は
結構好きです。JPEG 書き出しのサンプルを書いてみました。

▼手順
1.　明熊氏作成の [明熊JPEG保存DLL](フリー) をダウンロード
　　http://www.vector.co.jp/soft/win95/prog/se093621.html
2.　1. でダウンロードした圧縮ファイルを解凍し、SaveJPG.DLL を Windows
　　フォルダ内の System32 フォルダへコピー

これで OK です。

PP には CopyPicture メソッドがなかったので、一度ビットマップで書き出し
てから、それを Jpeg 変換しています。Excel ならこの手間が必要ありません。
CopyPicture でクリップボード経由でできますので。詳しくは、SaveJPG.DLL
添付のドキュメントをお読み下さい。

エラー処理とか、Jpeg のファイル名とか画像の挿入部分は省略しました。
付け足してご自分のツールとして完成させていただければ、幸いです。

基本的なメソッドしか使ってませんので、ちょこちょこ書き換えれば Excel や
Word でも動ごくと思います( ・∀・)

それにしても PP が書き出す JPEG はいけてないですね...では。

Option Explicit

' SaveJPG.DLL を Windows\System32 フォルダ内に置いて下さい
Declare Function SavetoJPEG Lib "SaveJPG.DLL" ( _
　　ByVal bmpf As String, _
　　ByVal jpgf As String, _
　　ByVal Value As Byte, _
　　ByVal Prgrs As Boolean) As Integer

' PP ファイル内の写真を全てスライド上のサイズで JPEG 書き出し
Sub OutputJpegFile()

　　Dim Sld　　　　As Slide
　　Dim Shp　　　　As Shape
　　Dim strDirPath As String
　　Dim strTmpname As String
　　Dim strJpgname As String
　　Dim lngCounter As Long

　　' SaveJPG.DLL 設定------------------------------------------
　　Const QUARITY = 100　　　　' 画質 1-100
　　Const PROGRESSIVE = False　' プログレッシブ True/False
　　'-----------------------------------------------------------

　　' 現在アクティブな PP ファイルのディレクトリ取得
　　strDirPath = ActivePresentation.Path

　　For Each Sld In ActivePresentation.Slides
　　　　For Each Shp In Sld.Shapes
　　　　　　' Shape Object は写真か？
　　　　　　If UCase$(Shp.Name) Like "PICTURE*" Then
　　　　　　　　' 一時ファイル名のビットマップで書き出す
　　　　　　　　strTmpname = GetTmpFilename(strDirPath)
　　　　　　　　Shp.Export strTmpname, ppShapeFormatBMP
　　　　　　　　' ビットマップが書き出されるまで待機
　　　　　　　　While CBool(Dir$(strTmpname) = "")
　　　　　　　　　　DoEvents
　　　　　　　　Wend
　　　　　　　　' Jpeg ファイル名生成
　　　　　　　　strJpgname = strDirPath & "\Picture" _
　　　　　　　　　　& Format$(lngCounter, "000") & ".jpg"
　　　　　　　　' ビットマップを SaveJPG.DLL で Jpeg 変換
　　　　　　　　Call SavetoJPEG(strTmpname, _
　　　　　　　　　　　　　　　　strJpgname, _
　　　　　　　　　　　　　　　　QUARITY, _
　　　　　　　　　　　　　　　　PROGRESSIVE)
　　　　　　　　' 一時ファイルを削除
　　　　　　　　Kill strTmpname
　　　　　　　　' カウントアップ
　　　　　　　　lngCounter = lngCounter + 1
　　　　　　End If
　　　　Next Shp
　　Next Sld

End Sub

' 指定フォルダ内で重複しない一時ファイル名を生成する関数
Private Function GetTmpFilename(ByRef strDirPath As String) As String
　　With CreateObject("Scripting.FileSystemObject")
　　　　Do
　　　　　　GetTmpFilename = .BuildPath(strDirPath, .GetTempName)
　　　　Loop Until GetTmpFilename <> ""
　　End With
End Function

お礼

さっそく、教えていただいた方法でためしてみました。
Excelでもやってみました。
私のやりたいことが出来ました！！（＾＾）
本当に感謝です！
わかりやく丁寧な説明をありがとうございました。

回答No.1

KenKen_SP

単に縮小（または拡大）画像を書き出したいだけなら、PowerPoint（PP）を
使う理由がわかりません。専用ソフトを使った方が綺麗に早く処理できる
からです。

是非とも PP でこの処理を行うご事情があるのであれば、その理由を具体
的に補足して下さい。

これを伺うのは、意図を理解しないで回答したがために発生する余計な
回答を省くのが目的です。PP 単体では恐らく難しいです。外部コンポー
ネント（DLL）を使って Jpg を書き出す方法か別アプリを経由する方法
などを想定しています。

お礼

画像をペイント開きサイズを縮小し、保存ファイル名に更新日をつけて保存するというのを手で行なっています。この処理を自動化するためにプログラム作成を考えました。

そこで、私はVBAの知識が少しあるのでマクロの記録を流用して簡単にプログラムができるのではないかと思ったため、マクロを使用しようと思いました。

PP単体では難しいようでしたら、他の方法に変えたいと思います。
ご回答ありがとうございました。