ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい。

Excelのシートに以下のマクロを組みましたが、空白でダブルクリックして、写真選択。
写真をダブルクリックで貼付けまではいいのですが、画像にリンクが設定されてしまい、
元データを削除すると、貼り付けた画像まで消えてしまいます。
マクロは、詳しくないので、貼り付ければいいようにお願いいしたいです。
よろしくお願い致します。

＜下記に構文を添付＞

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' ターゲットセルが指定したセル（A2, C2, A4, C4, A6, C6）のいずれでもない場合、CancelをTrueに設定します。
Cancel = True

' ターゲットセルが指定したセル（A2, C2, A4, C4, A6, C6）のいずれかであれば、処理を実行します。
If Not Intersect(Target, Union(Range("ar2:ar20"), Range("at2:at20"), Range("av2:av20"), Range("ax2:ax20"), Range("az2:az20"), Range("bb2:bb20"), Range("bd2:bd20"), Range("bf2:bf20"), Range("bh2:bh20"), Range("bj2:bj20"), Range("bl2:bl20"))) Is Nothing Then
' ファイル選択ダイアログを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select an Image File" ' ダイアログのタイトルを設定します。
.Filters.Clear ' 既存のフィルターをクリアします。
.Filters.Add "Image Files", "*.GIF; *.JPG; *.JPEG; *.BMP; *.PNG; *.TIF", 1 ' 画像ファイルのフィルターを追加します。

' ダイアログで画像が選択されたら、その画像をダブルクリックされたセルに挿入します。
If .Show = -1 Then
Dim Picture As Picture
Set Picture = ActiveSheet.Pictures.Insert(.SelectedItems(1))

' 挿入した画像のサイズと位置をダブルクリックされたセルに合わせます。

With Picture
With .ShapeRange
.LockAspectRatio = msoFalse
.Width = Target.Width * 0.85
.Height = Target.Height * 0.9
'セルの中央（横方向/縦方向の中央）に配置
.Left = Target.Left + (Target.Width - .Width) / 2
.Top = Target.Top + (Target.Height - .Height) / 1.5
End With
Application.ScreenUpdating = True
Cancel = True
.Placement = xlMoveAndSize
End With
End If
End With
End If

変更箇所をお願いします。

No.2 回答者： fujillin 回答日時： 2025/02/22 11:00

No1です。

御質問文に
＞以下のマクロを組みましたが～～
とありましたので、（詳しい/詳しくないかは関係なく）組んだのであればわかるであろう回答をしました。

>本文の修正箇所をご教授お願いします。
No1に記した通り、「Pictures.Insert」メソッドを「Shapes.AddPicture」メソッドに置き換えれば、リンクのコントロールは可能になります。

とは言え、コードを作成する気はないらしいので・・・


ご提示のコード中のコメントと実際の処理が異なっている部分があちこちありますが、コードの方を正と解釈しました。
特に、
＞'セルの中央（横方向/縦方向の中央）に配置
とありますが、コード通りに中央ではなくずらした位置にしてあります。

無駄や重複もあるので処理方法や記述は変えましたが、処理内容は「画像のリンク」以外は同じになるようにしたつもりです。
（画像の縦横比を変えてしまうのにも違和感を覚えますがそのままです）

Private Sub Worksheet_BeforeDoubleClick( _
　ByVal T As Range, Cancel As Boolean)
Dim P As String

Cancel = True
If Intersect(T, Range("AR2:BL20")) Is Nothing Or T.Column Mod 2 = 1 _
Then Exit Sub

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select an Image File"
.Filters.Clear
.Filters.add "Image Files", "*.GIF; *.JPG; *.JPEG; *.BMP; *.PNG; *.TIF", 1
If .Show = 0 Then Exit Sub
P = .SelectedItems(1)
End With

With ActiveSheet.Shapes.AddPicture(P, 0, -1, T.Left + T.Width * 0.075, _
　T.Top + T.Height / 15, T.Width * 0.85, T.Height * 0.9)
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
End With
End Sub

この回答へのお礼

早速の対応ありがとうございます。
大変助かりました。
役所対応で写真提出（２０００枚位）しなければいけなかったのたすかりました。

お礼日時：2025/02/22 13:08

No.1 回答者： fujillin 回答日時： 2025/02/20 11:51

こんにちは

Pictures.Insertでも可能なのかも知れませんが仕様の説明が読み切れません。
第二引数に「object：Converter」とありますが、Converterにどのような指定をすればよいのかわかりませんでした。
https://learn.microsoft.com/ja-jp/dotnet/api/mic …

一方で、Shapes.AddPictureメソッドを利用すれば、第二引数にLinkToFileがあり、msoFalseを指定すればリンクをせずに画像貼り付けが可能になりますので、こちらを利用して貼り付けるようにすればよいでしょう。
https://learn.microsoft.com/ja-jp/office/vba/api …

この回答へのお礼

早々の返答ありがとうございます。
本文の書いてる通り、マクロ超初心者のためやり方がわかりません。
本文の修正箇所をご教授お願いします。
*構文もネットよりコピペしております。

お礼日時：2025/02/20 18:44