[[20200411075712]]　『画像貼り付けで上書きされてしまう』（VBA初心者）　ページの最後に飛ぶ

『画像貼り付けで上書きされてしまう』（VBA初心者）

お世話になります。
【エクセルでダブルクリックし、画像フォルダより
画像を選択し、セルの中央に空白部分を作って、実像として貼り付け】
という
VBA素人ながらネットで調べまくって
下記のコードを作りました。
Option Explicit

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    Dim myF As Variant
    Dim mySp As Object
    Dim myAD1 As String
    Dim myAD2 As String
    Dim myHH As Double
    Dim myWW As Double
    Dim myHH2 As Double
    Dim myWW2 As Double

    Cancel = True
    '===============?I??Z?????
    If Intersect(Range("F6:J40"), Target) Is Nothing Then Exit Sub
    '===============???I??
    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "????I??", , False)
    If myF = False Then
        MsgBox "????I????????????(?I??)"
        Exit Sub
    End If
    '===============????|??
    For Each mySp In ActiveSheet.Shapes
        myAD1 = mySp.TopLeftCell.MergeArea.Address
        myAD2 = Target.Address
        If myAD1 = myAD2 Then mySp.Delete
    Next
    '===============????\??t??
    Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
        Width:=0, Height:=0)    '?c???O??B
    mySp.ScaleHeight 1, msoTrue '????T?C?Y????
    mySp.ScaleWidth 1, msoTrue  '????T?C?Y????
    mySp.LockAspectRatio = msoTrue '?c?????????
        '===============?^?e???R??k?????
    If mySp.Width > Target.Width Then mySp.Width = Target.Width - 10
    If mySp.Height > Target.Height Then mySp.Height = Target.Height - 10
    '===============?????????
    myHH2 = (Target.Height / 2) - (mySp.Height / 2)
    myWW2 = (Target.Width / 2) - (mySp.Width / 2)
    mySp.Top = Target.Top + myHH2
    mySp.Left = Target.Left + myWW2

    Set mySp = Nothing

 End Sub

ですが、
張り付けると前からあった画像が上書きされて消えてしまいます。
写真に名称等をテキストで張り付けてあったのですが
写真を入れ替えるのにVBAで張り付けると消えてしまいます。
このコードになにをいれればいいのでしょうか？

ご指導宜しくお願い致します。
OSはWINDOWS10です

＜使用 Excel：Excel2010、使用 OS：unknown ＞

    For Each mySp In ActiveSheet.Shapes
        myAD1 = mySp.TopLeftCell.MergeArea.Address
        myAD2 = Target.Address
        If myAD1 = myAD2 Then mySp.Delete
    Next
ここで削除していますよね。それは理解されているのでしょうか？
（γ） 2020/04/11(土) 08:13

γ様
返信ありがとうございます。

すいません自己解決しました。
そこは理解していて
コードを消したのですが
消していないシートで試していて
出来ない出来ないと焦っていました。

消したシートでやってみたところ
出来ました。
申し訳ないです。

あと別の質問なのですが
最背面はmsoSendToBackの使用で良いと思うのですが
どこにどのようにいれればよろしいのでしょうか？
宜しくお願いします。
（VBA初心者） 2020/04/11(土) 08:27

＞最背面はmsoSendToBackの使用で良いと思うのですが
何をしたいのかによります。その説明がないので、わかりません。
（γ） 2020/04/11(土) 08:34

γ様
お世話になります。
説明不足で申し訳ないです。

テキストとかのオブジェクトは同じものですので
画像だけ変更するときに
上記VBAで読み込んで自動で張り付けてあるオブジェクトの背面に貼り付け
ということをしたいのですが。

今のですと読み込んだ場合最前面にくるので一つ一つ最背面にという作業をしています。

よろしくお願いします。

（VBA初心者） 2020/04/12(日) 09:10

挿入した直後に
mySp.ZOrder msoSendToBack
などとしてみたのでしょうか。不都合が起きますか？
上手くいかなければ、別のところで試してみては？
（γ） 2020/04/12(日) 09:30

お世話になります。

myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2

この下に挿入したら出来ました。

色々ご教授ありがとうございました。
（VBA初心者） 2020/04/12(日) 10:02

コメント返信：

[ 一覧(最新更新順) ]

[[20200411075712]] 『画像貼り付けで上書きされてしまう』（VBA初心者） ページの最後に飛ぶ

[[20200411075712]]　『画像貼り付けで上書きされてしまう』（VBA初心者）　ページの最後に飛ぶ