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

Question

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

fujillin · Accepted Answer

こんにちは

＞縦長の写真の場合うまくいきません。
想像するところ、原因は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

Qchan1962 · Answer

良く読めばよかった
zongai 様　そう言う事ですね
＃３　＞＞縦長　以下は忘れてください

Qchan1962 · Answer

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

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

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

zongai · Answer

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

正常に貼れる横長の画像のコピーを作って、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として処理できたはず。

zongai · Answer

丸投げじゃなくて、どの部分で処理がおかしくなるかくらい絞り込みましょうよ。
ステップイン（F8)で処理を順に追えば、どこまで処理がうまくいってるかわかるでしょ？

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

Application.ScreenUpdating = False

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

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

こんにちは

良く読めばよかった

こんばんは

実行してみました。

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

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング