Excel2010でのマクロによる画像貼付について

質問

エクセル2010で下記のマクロを実行し、一旦保存して再度開くと、
「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」
と表示されます。
検索したところ、Pictures.Insertでなく、2010では、Shapes.Addを使用するとの事ですが、
マクロに詳しく無いため、どこを修正したらいいのかわかりません。
大量の写真貼り付けがあるので、教えて頂けると大変助かります。
どうぞよろしくお願いいたします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

'===============起動の合図
If ActiveCell.FormulaR1C1 = "画像" Then

Cancel = True

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

'===============画像の貼り付け
Set CCC = ActiveSheet.Pictures.Insert(SSS)

'===============タテヨコの縮尺を保持
HH = Target.Height / CCC.Height
WW = Target.Width / CCC.Width
If HH > WW Then
CCC.Height = CCC.Height * 0.99
CCC.Width = Target.Width * 0.99
Else
CCC.Height = Target.Height * 0.99
CCC.Width = CCC.Width * 0.99
End If

'===============中央へ調整
HH2 = (Target.Height / 2) - (CCC.Height / 2)
WW2 = (Target.Width / 2) - (CCC.Width / 2)
CCC.Top = Target.Top + HH2
CCC.Left = Target.Left + WW2

Set CCC = Nothing
End If

End Sub

回答No.2

kybo · ベストアンサー

一度Insertで挿入して、W,Hサイズだけ取得し、画像をけし、AddPictureで再度挿入すればいいです。

かなり適当に修正したので、あとは、ご自分で修正して下さい。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

'===============起動の合図
If ActiveCell.FormulaR1C1 = "画像" Then

Cancel = True

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

'===============画像の貼り付け
Set CCC = ActiveSheet.Pictures.Insert(SSS)
W = CCC.Width
H = CCC.Height
CCC.Delete
Set CCC = ActiveSheet.Shapes.AddPicture(SSS, msoFalse, msoTrue, Target.Top, Target.Left, Target.Width, Target.Height)

'===============タテヨコの縮尺を保持
HH = Target.Height / H
WW = Target.Width / W
If HH > WW Then
CCC.Height = H * 0.99
CCC.Width = Target.Width * 0.99
Else
CCC.Height = Target.Height * 0.99
CCC.Width = W * 0.99
End If

'===============中央へ調整
HH2 = (Target.Height / 2) - (CCC.Height / 2)
WW2 = (Target.Width / 2) - (CCC.Width / 2)
CCC.Top = Target.Top + HH2
CCC.Left = Target.Left + WW2

Set CCC = Nothing
End If

End Sub

お礼

お忙しいところご教授いただきありがとうございました。

回答No.1

kybo

Set CCC = ActiveSheet.Pictures.Insert(SSS)

を、以下の様に書き換えてみて下さい。

Set CCC = ActiveSheet.Shapes.AddPicture(SSS, msoFalse, msoTrue, Target.Top, Target.Left, Target.Width, Target.Height)

補足

「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」
というメッセージは出なくなりました。
ありがとうございました。
それで、元の画像の縮尺を変えたくないのですが、（画像サイズがまちまちのため）
何か手段はありますか？
お手数おかけして申し訳ありません<m(__)m>