EXCELに画像を貼り付けマクロの画像大きさ調整にについて教えてください。

Excelマクロについては初心者です。
特定のフォルダにある画像をExcelシートに自動で貼り付けるマクロが必要になりました。
EXCELシートは添付画像のように単純な形式です。
A2セルに画像名入力
A1セルに画像を自動で貼り付け
条件：自動で貼り付けた画像は縦横比率でA１セルに強制的に収める
以下のマクロはA2セルに画像名を入力し、excelファイル開く直したときにA１セルにA2セルに入力されている名前の画像ファイルを貼り付けるという内容のマクロです。
マクロをいろいろいじってみて、画像貼り付け、中央揃えまでは上手くいったような気がしますが、
画像が小さく貼り付けてしまいまして（添付画像）、画像の大きさを調整に困っています。
ーーーーーーーーーーーーーーー
Private Sub Workbook_Open()
Dim shape As shape
Dim myRange As Range '画像を配置するセル範囲
Dim rX As Double, rY As Double
Dim objShape As shape

Set myRange = Range("A1")
Set targetRange = Range("A2")
With ActiveSheet.Pictures.Insert("C:\Users\ovner\Pictures\" & targetRange & ".jpg")
.Left = myRange.Left
.Top = myRange.Top
With .ShapeRange
.LockAspectRatio = msoTrue
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue

rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With

Application.ScreenUpdating = True
Cancel = True
End With

End Sub

ーーーーーーーーーーーーーーー
質問１：どすれば画像ファイルを縦横比率でA１セルに縦いっぱいまで拡大し、貼り付けすることができるでしょうか？

質問2：”　ActiveSheet.Pictures.Insert("C:\Users\ovner\Pictures\" & targetRange & ".jpg")　”
　　　　　このコードだと画像はリンクになると思いますが、
　　　　　
　　　　：”　ActiveSheet.Shapes.AddPicture("C:\Users\ovner\Pictures\" & targetRange & ".jpg")　”
このように、リンクではない形式でも画像を自動貼り付けできるでしょう？
教えてください。よろしくお願いします。

No.1 回答者： Qchan1962 回答日時： 2021/05/10 18:13

こんにちは

＞質問１
縦横比率を変えず、幅もしくは高さがセルのいずれかにいっぱいになるようなサイズ変更でしょうか？
コードを見ると縦横共にいっぱいに成るようになっているようですが

＞質問2
＞ActiveSheet.Shapes.AddPicture("C:\Users\ovner\Pictures\" & targetRange & ".jpg")　”
このように、リンクではない形式でも画像を自動貼り付けできるでしょう？

はい出来ます。


Workbook_OpenやCancel = Trueを見ると、まだまだ問題が出て来そうですが、セルの関係から、複数取得なども考えられているのでしょうか？

下記にご質問のコードで標準モジュールに書き、ボタンなどから実行するサンプルを書きます。一応Dirで取得時のエラー回避を入れて置きます。

質問１については、ご質問コードそのままなのでせるの縦横いっぱいに表示されると思います。取敢えずの参考にしてください。

Private Sub test()
Dim shape As shape
Dim myRange As Range '画像を配置するセル範囲
Dim targetRange As Range
Dim filePath As String, strFileName As String
Dim rX As Double, rY As Double
Dim objShape As shape
Set myRange = Range("A1")
Set targetRange = Range("A2")

filePath = "C:\Users\ovner\Pictures\"
strFileName = Dir(filePath & targetRange & ".jpg")
If strFileName = "" Then MsgBox ("対象ファイルはありません"): Exit Sub
With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With
End Sub

この回答へのお礼

Qchan1962様　ありがとうございました。
質問１の件ですが、おっしゃった通り　縦横比率を変えず、幅もしくは高さがセルのいずれかにいっぱいになるようにしたいでした、私も昨日いろいろ試してみました。訳が分からないですが、「.LockAspectRatio = msotrue」 部分のtrue をfalseに変えるか、この行を削除で質問1の目的が達成しました。
質問2ですが、ボタン式も考えたんですが、200ぐらいのexcelファイルにすべてボタン作るのはどうかなと思ってやめました。
With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
この部分を参考にさせていただきました。ありがとうございました。
Set myRange = Range("A1")
Set targetRange = Range("A2")
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:="C:\Users\ovner\Pictures\" & targetRange & ".jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, _
Top:=1, _
Width:=0, _
Height:=0)
このように変更することで目的を達成しまた。
毎回エクセルファイルを開いたときに写真が貼り付けられファイルサイズが大きくなるので、ファイルを閉じたときに画像をいったん削除するようにマクロを追加しました。

お礼日時：2021/05/11 10:24

No.2 回答者： Qchan1962 回答日時： 2021/05/10 18:34

＃１です

＞質問１
縦横比率を変えず、高さがセルいっぱいになるようなサイズ変更でしょうか？
かも知れませんので　With ActiveSheet.Shapes.AddPicture　部分を下記のようにします。幅をセル内に収める場合は、コメントアウトしている部分を実行コードにしてください。（いろいろ試してください）

With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
.LockAspectRatio = msoTrue '比率を固定
'幅をセル内に収める（下3行を生かすと幅が超える場合幅に合わせます）
' If .Width > myRange.Width Then
' .Width = myRange.Width
' End If
If .Height > myRange.Height Then '高さをセル内に収める
.Height = myRange.Height
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With