パワーポイントでトリミングを繰り返し行うマクロ

質問

パワーポイント上で少しずつトリミングを行うマクロを作成したいと思っています。

キー操作の記録でトリミングのコードを確認したところ、以下のようになっていました。
---
ActiveWindow.Selection.ShapeRange.PictureFormat.CropRight = 67.75

変数を1つ定義して、現在のトリミング値を取得し、そこに10ずつさらにトリミングしていくようなマクロを作成しようと思っているのですが、現在のトリミング値を取得するにはどうやればいいのでしょうか。

最後に.Valueをつけて、変数に代入しようとしましたがうまくいきませんでした。

またトリミング後に図の圧縮も行いたいので、圧縮のマクロ記述方法もご教授願います。

回答No.2

n_na_tto

ごめんなさい。
ゆっくり考えたら簡単なことでした。
最初のコードはなしでお願いします。

Sub test()
Dim Shp As Shape
For Each Shp In ActiveWindow.Selection.ShapeRange
　With Shp
　　With .PictureFormat
　　　.CropRight = .CropRight + 10
　　End With
　End With
Next
End Sub

Sub test2()
Dim myWidth As Single, origWidth As Single
With ActiveWindow.Selection.ShapeRange(1)
　With .PictureFormat
　　.CropRight = .CropRight + 10
　End With
End With
End Sub

お礼

ご教授、ありがとうございます。ものすごく助かりました。
最初のコードでできたので、すでにマクロをキーボードに割り当て済なのですが、新しいコードで再度やってみます。
ありがとうございます。

回答No.1

n_na_tto

一時的に複写して右のトリミングを0にして横幅を取得、
それと現在の横幅の差をとれば、現在の右のトリミングだと思います。

ほかにも方法はあるかもしれませんが、
考えるの面倒なので、とりあえず。

・複数図形を選択していれば、そのすべてに対して
トリミングするとき
Sub test()
Dim Shp As Shape
Dim myWidth As Single, origWidth As Single
For Each Shp In ActiveWindow.Selection.ShapeRange
With Shp
myWidth = .Width '現在の横幅
With .Duplicate '複写
.PictureFormat.CropRight = 0 '右のトリミング解除
origWidth = .Width 'もともとの横幅
.Delete 'もういらない、ご苦労様
End With
.PictureFormat.CropRight = origWidth - myWidth + 10
End With
Next
End Sub

・ひとつの選択図形のみ
Sub test2()
Dim myWidth As Single, origWidth As Single
With ActiveWindow.Selection.ShapeRange(1)
myWidth = .Width '現在の横幅
With .Duplicate '複写
.PictureFormat.CropRight = 0 '右のトリミング解除
origWidth = .Width 'もともとの横幅
.Delete 'もういらない、ご苦労様
End With
.PictureFormat.CropRight = origWidth - myWidth + 10
End With
End Sub