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
