【VBA】写真の貼り付けコードがうまく機能しません。

VBAについての質問です。
下記のように、結合したセルをダブルクリックした場合に、セルの大きさに合わせて画像を張り付けられるようなコードを作成したのですが、縦長の写真の場合うまくいきません。
どのように修正したらよいでしょうか？
詳しい方よろしくお願い致します。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'セル選択判定
'条件①結合セル②セル高さ100以上③セル幅100以上
If Target.MergeCells And Target.Height >= 100 And Target.Width >= 100 Then

Cancel = True

'画像挿入
Call PasteImage(Target)
End If

End Sub

Public Sub PasteImage(ByVal Target As Range)

Dim fileNm As String
Dim shp As Object
Dim rng As Range
Dim myRange As Range
Dim pWidth As Single
Dim pHeight As Single
Dim pLeft As Single
Dim pTop As Single
Dim mWidth As Integer
Dim mHeight As Integer
Dim rX As Single
Dim rY As Single
Dim objShape As Shape

'画像選択
fileNm = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If fileNm = "False" Then
MsgBox "画像を選択してください"
Exit Sub
End If

'セル内の画像削除
For Each shp In ActiveSheet.Pictures
Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)

If Not (Intersect(rng, Selection) Is Nothing) Then
shp.Delete
End If
Next

mWidth = 2 '左右余白
mHeight = 15 '上下余白
Set myRange = Target
Application.ScreenUpdating = False

'表示位置の取得
With ActiveSheet.Pictures.Insert(fileNm).ShapeRange
'左上隅の位置取得
pLeft = .Left
pTop = .Top
'一旦画像を削除する
.Delete
End With

'画像サイズの取得
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:=fileNm, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)

With objShape
.LockAspectRatio = msoTrue
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue

'画像サイズをセルの幅、高さに合わせる
rX = myRange.Width / .Width
rY = myRange.Height / .Height

If rX > rY Then
.Height = .Height * rY - mHeight
.Width = .Width - mWidth
Else
.Height = .Height - mHeight
.Width = .Width * rX - mWidth
End If
pWidth = .Width
pHeight = .Height

'表示位置をセルの幅、高さに合わせる
pLeft = pLeft + (myRange.Width - .Width) / 2
pTop = pTop + (myRange.Height - .Height) / 2
'一旦画像を削除する
.Delete
End With

'画像の貼り付け
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:=fileNm, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=pLeft, _
Top:=pTop, _
Width:=pWidth, _
Height:=pHeight)

Application.ScreenUpdating = True

End Sub

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

• ありがとうございます。
  処理自体は正常に完了するのですが、縦長の画像の場合、セルの中央に配置されずアスペクト比が横長の画像になってしまうので直したいです。

  No.1の回答に寄せられた補足コメントです。 補足日時：2022/09/01 18:54

No.5 ベストアンサー 回答者： fujillin 回答日時： 2022/09/02 10:59

こんにちは

＞縦長の写真の場合うまくいきません。
想像するところ、原因はNo2様のご指摘にある通りではないかと思います。
WとHを入替えれば済むと思いますが、回転角がピッタリ90度の倍数でないと上手くいきません。
入替えの判定をするのも面倒なので、一般化して、回転している画像の外枠（＝いわゆるBounding Box）のW、Hに換算してしまえば、回転角が45度や30度でも対応可能になりますし、一律の計算ですむものと考えられます。

また、ご質問には直接関係ありませんが、
＞mWidth = 2 '左右余白
＞mHeight = 15 '上下余白
と余白を設定しているにも関わらず、比率の計算は
＞rX = myRange.Width / .Width
＞rY = myRange.Height / .Height
のように、余白を考慮していないので誤差が生じることになると思われます。
また、コメントの上下と左右が、実際には入替わって計算されていませんか？

さらには、No3様のご指摘にもあるように、同じ画像を何度も描画したり消したりする必要性も感じられません。


・・・ということで、余白の設定以降を以下のようにしてみてはいかがでしょうか？
※ fileNm 等必要な変数は設定済みとします。
※ 追加した変数は、新たに宣言してあります。
　（ご提示の変数とは変えてありますので、不要な変数がでます）
※ 画像の回転は通常の回転だけを考慮していますので、エクセルの「3D回転」などの回転には対応していません。（多分、他のソフトでこのような設定はされないと思いますので）

Dim iW As Single, iH As Single
Dim rS As Double, rC As Double

With ActiveSheet.Shapes.AddPicture(Filename:=fileNm, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=0, Top:=0, Width:=0, Height:=0)
' 一旦実寸化
.LockAspectRatio = msoTrue
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue

' 画像の外枠を計算
rS = .Rotation * Atn(1) / 45
rC = Cos(rS)
rS = Sin(rS)
iW = Application.Max(Abs(.Width * rC - .Height * rS), Abs(.Width * rC + .Height * rS))
iH = Application.Max(Abs(.Width * rS + .Height * rC), Abs(.Width * rS - .Height * rC))

' サイズ・位置を調整
.Width = .Width * Application.Min( _
(Target.Width - 2 * mWidth) / iW, (Target.Height - 2 * mHeight) / iH)
.Left = Target.Left + (Target.Width - .Width) / 2
.Top = Target.Top + (Target.Height - .Height) / 2
End With

No.4 回答者： Qchan1962 回答日時： 2022/09/01 20:09

良く読めばよかった

zongai 様　そう言う事ですね
＃３　＞＞縦長　以下は忘れてください

No.3 回答者： Qchan1962 回答日時： 2022/09/01 19:40

こんばんは

なぜ何度も同じ画像を貼ったりdelしたりするのでしょう？
なんか2度手間3度手間では無いでしょうか・・・
試していないので頭が混乱していますが、
＞縦長
rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Thenの否定なので

単純に
Else
.Height = .Height * rY - mHeight
.Width = .Width * rX - mWidth
ではダメかな？

見当違いならごめんなさい

No.2 回答者： zongai 回答日時： 2022/09/01 19:22

実行してみました。

中身を全部見たわけではないですが、現象がおきるのは
縦長の画像　ではなく　元の画像を回転したもの　だと思われます。

正常に貼れる横長の画像のコピーを作って、90度回転して貼り付けてみてください。
おかしくなると思います。

これね、
私も、画像貼り付けマクロを作った際に頭を悩ませたところです。

回転した画像を貼り付けた場合、その画像のTop,Leftは、
見えてる画像のTop,Leftではなく、
『回転する前の状態の画像のTop,Leftになる！！』
という。
Width,Heightも入れ替わります。

画像を.Rotateプロバティで回転角度を取得し、
90度、270度回転している場合に、それを意識した処理をする必要があります。

詳しくはこちらの記事が参考になるでしょう。
↓
【Excel】回転させた画像をシートに貼り付ける
https://atsumitm.iobb.net/it/it-025.php
（添付画像もこちらから）


画質気にしなければ、貼り付けた瞬間に、Cut、Pasteすれば、
見たままのTop,Leftとして処理できたはず。

No.1 回答者： zongai 回答日時： 2022/09/01 18:48

丸投げじゃなくて、どの部分で処理がおかしくなるかくらい絞り込みましょうよ。

ステップイン（F8)で処理を順に追えば、どこまで処理がうまくいってるかわかるでしょ？

それから、正常動作が確認されないうちから

Application.ScreenUpdating = False

つかっちゃ駄目。
これは仕上げに付け足すもの。