excel マクロ 画像挿入

質問

以下のマクロでリンク貼り付けではない　画像挿入を作成しようと思いましたがエラーになります

詳しい方　修正　お願いいたします

当方のしたい事としましては

選択したセルでのみに画像挿入　リンクではない画像貼り付け

以下例では　B3,B17,B31,B46,B60,B74　セルをダブルクリックすればそこに画像を挿入です

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As 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
If Not Intersect(Range("B3,B17,B31,B46,B60,B74"), Target) Is Nothing Then
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
Cancel = True

'===============画像選択
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
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
'===============画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0) '★　とりあえず　縦横０で。
mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す
'===============タテヨコの縮尺を保持
If mySp.Width > Target.Width Then mySp.Width = Target.Width
If mySp.Height > Target.Height Then mySp.Height = Target.Height
'===============中央へ調整
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

回答No.1

keithin · ベストアンサー

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As 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

　If application.Intersect(Range("B3,B17,B31,B46,B60,B74"), Target) Is Nothing Then exit sub
’myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
　Cancel = True

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

'===============画像の掃除
　on error resume next
　activesheet.shapes("Pict" & target.address).delete

'===============画像の貼り付け
　with activesheet.pictures.insert(filename:=myf)
　　.name = "Pict" & target.address

'===============中央へ調整
　　.shaperange.lockaspectratio = true
　　.height = application.min(.height, target.height)
　　.width = application.min(.width, target.width)
　　.left = target.left + (target.width - .width) /2
　　.top = target.top + (target.height - .height) /2
　end with

End Sub
みたいな。

お礼

自己解決致しました　ありがとうございました　m(_ _)m

補足

エラーは出なくなったのですが　やはり元データ削除や移動すれば　リンク貼り付けになってますので消えてしまいます　どなたかお願い致します

調べたら
Pictures.Insertメソッドではなく
Shapes.AddPictureメソッドを使って書いたら大丈夫らしいのですが構文がややこしくて