【VBA】写真の縦横比を変えずに貼り付ける

ご覧いただきありがとうございます。
VBA初心者です。
この度、写真の貼付を自動化したく、
インターネットで見つけたコードを使ってみたのですが
セルの大きさに合わせて写真の縦横比が変わってしまいます。

このコードを、縦横比を変えずに、セルの大きさに合わせて貼付するためには
（イメージを画像で載せております）
その部分を修正すればよいでしょうか？

ご教授のほどよろしくお願いいたします。


ーーーーーーー以下コードーーーーーーーー

Sub 写真貼付1name() 'ファイル名付き

'ファイル読み出し用変数
Dim filename As Variant

'写真読み込み用変数
Dim pic As Shape

'ファイルを纏めて読み込む
filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)

'filenameの配列か確認
If IsArray(filename) Then

'ファイル選択数分繰り返す
For i = 1 To UBound(filename)

'オブシェクト名を省略
With ActiveCell

'写真のサイズをセルの大きさに合わせて貼付け
Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(i), linktofile:=False, savewithdocument:=True, _
Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4)
End With

'セルの貼り付け位置を設定
ActiveCell.Offset(3, 0).Activate

Next i

End If

End Sub

質問者からの補足コメント

• ありがとうございます。
  画像の表示位置は中央になっています。
  サンプル画像で試してみたところはみ出ることはなかったのですが
  実際に貼り付けたい画像（黒塗りにしています）で試すと
  書いていただいた部分を変更してもはみ出てしまいます、、、

  
  No.4の回答に寄せられた補足コメントです。 補足日時：2023/06/14 11:43

No.2 ベストアンサー 回答者： fujillin 回答日時： 2023/06/13 13:42

こんにちは

セルサイズにピッタリ合わせるのではなく、周囲に2pt分の隙間を作りたいということと解釈しました。
　LockAspectRatio = True
で、画像は縦横比を維持するようになりますので、セルサイズと縦・横の小さな方に合わせて縮小・拡大し、その上で位置をセルと中央合わせに表示すればよさそうですね。

Sub 写真貼付1name()
Dim filename As Variant
Dim pic As Shape
Dim rng As Range, i As Long

filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
If Not IsArray(filename) Then Exit Sub
Set rng = ActiveCell.MergeArea

For i = 1 To UBound(filename)
Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(i), _
linktofile:=False, savewithdocument:=True, _
Left:=rng.Left, Top:=rng.Top, Width:=-1, Height:=-1)
pic.LockAspectRatio = True
pic.Width = rng.Width - 2
If pic.Height > rng.Height - 2 Then pic.Height = rng.Height - 2
pic.Top = rng.Top + (rng.Height - pic.Height) / 2
pic.Left = rng.Left + (rng.Width - pic.Width) / 2
Set rng = rng.Offset(3).MergeArea
Next i
End Sub

No.5 回答者： fujillin 回答日時： 2023/06/14 12:22

No4です。

補足を見ましたが、それって画像が回転しているのではありませんか？
回転画像の場合、実際の縦・横の長さと、見た目の縦・横の長さが逆転しますので・・

回転画像にも対応するのなら、以下をご参照ください。
https://oshiete.goo.ne.jp/qa/13123440.html

この回答へのお礼

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

お礼日時：2023/06/15 11:02

No.4 回答者： fujillin 回答日時： 2023/06/14 11:29

No3です。

＞縦が結合セルの幅より少し上下にはみ出てしまうのですが、
＞画像をセルの縦幅に収まるようにするにはどうしたら良いでしょうか？
当方の環境で試した限りではおさまりますけれどね・・・
ロジック的にもはみ出ることはないはずなんですけれど。

当方では事象が再現しないので何ともわかりかねますが、どのような環境下でどのように実行しているのかにもよります。
再現できる状態で、サイズの計算途中の値がどうなっているかなどをチェックしてみないとわかりませんね。

見た目にわかりやすくするなら、

＞pic.Width = rng.Width - 2
＞If pic.Height > rng.Height - 2 Then pic.Height = rng.Height - 2

部分を、

　pic.Width = rng.Width
　If pic.Height > rng.Height Then pic.Height = rng.Height

としておけば、セルサイズにぴったりとなるはずですけれど、これでもはみ出すのでしょうか？

もしそうなら、画像サイズかセルサイズのどちらかを正しく取得できていないことになりますけれど・・
一方で、画像の表示位置がセルと中央合わせになっているのであれば、正しく取得できていることになるのですけれど、位置もずれているのでしょうか？

No.3 回答者： fujillin 回答日時： 2023/06/13 15:12

No2です。

すみません。計算を間違えてました。
2ptの隙間なら両側で4ptでしたね。

＞rng.Width - 2
等、何か所か間違えがありますので、修正しておいてください。
正：　rng.Width - 4　　ですね。（おはずかしい・・）

この回答へのお礼

回答ありがとうございます！
書いていただいたコードで試してみたところ、
縦が結合セルの幅より少し上下にはみ出てしまうのですが、
画像をセルの縦幅に収まるようにするにはどうしたら良いでしょうか？
VBAに関して無知のため、変な質問をしてしまっていたらすみません、、
他に必要な情報等あればおっしゃってください。
何度も申し訳ございませんが、よろしくお願いいたします。

お礼日時：2023/06/14 10:48

No.1 回答者： 初心者ですが何か。 回答日時： 2023/06/13 13:21

Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4

この部分がサイズを変更しているので、Bookをコピーしてから上記を削除し実行してみるとか？

ただセルの結合については参考サイトのコードなのか目的のコードなのかによっては、上記を削除ではないかも知れませんけど。