VBAでエクセルのシート上の画像のリサイズと配置を行いたい

以前、ネットで以下のような条件でリサイズできるコードを見つけ重宝していました。

・シート上の画像全てがリサイズできる
・縦横比は維持する
・画像の左上端がおさまっているセルの大きさに対して
　上下左右わずかに余白が生じるサイズにし、セルの中心におさめる

データが消えてしまい再度探したのですがどうしても見つからないため、
どなたか上記が実現できるコードを教えていただけるとありがたいです！

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/11/21 22:22

こんばんは、

参考になるか分かりませんが、サンプルです。

Sub ShapeResize()
Dim shp As Shape
Dim shpCell As Range
　　For Each shp In ActiveSheet.Shapes
　　　　With shp
　　　　　　Set shpCell = .TopLeftCell
　　　　　　.LockAspectRatio = msoTrue
　　　　　　.Height = shpCell.Height * 0.9
　　　　　　If .Width > shpCell.Width Then
　　　　　　　　.Width = shpCell.Width * 0.9
　　　　　　End If
　　　　　　.Left = shpCell.Left + (shpCell.Width - .Width) / 2
　　　　　　.Top = shpCell.Top + (shpCell.Height - .Height) / 2
　　　　End With
　　　　Set shpCell = Nothing
　　Next shp
End Sub

・シート上の画像全てがリサイズできる
For Each shp In ActiveSheet.Shapes

・縦横比は維持する
.LockAspectRatio = msoTrue

・画像の左上端がおさまっているセルの大きさに対して
Set shpCell = .TopLeftCell　'セルをセット

上下左右わずかに余白が生じるサイズにし、
.Height = shpCell.Height * 0.9
If .Width > shpCell.Width Then
.Width = shpCell.Width * 0.9
End If

*Shapeの大きさとセルの大きさが分からないのと比を維持する為に
セルの幅、高さの小さい方に合わせてリサイズしリサイズされた
ShapeがshpCell.Widthに収まっていない場合は、
更にshpCell.Widthでリサイズしています。

セルの中心におさめる
.Left = shpCell.Left + (shpCell.Width - .Width) / 2
.Top = shpCell.Top + (shpCell.Height - .Height) / 2

この回答へのお礼

ありがとうございます！
まさに実現したい動きをしてくれるもので本当に助かりました！
それぞれのコードの働きも書いてくださったので
アレンジしたパターンが必要になった時には参考にさせていただきます。

お礼日時：2020/11/22 09:35