マクロを使って連続画像貼り付け→リンクを外す

マクロ初心者です。
マクロを使って連続画像貼り付けするシートを作成しました。

C:\Users\画像\に番号ごとの画像を置き、
ｎ３：ｎ5に画像番号を入力すると、指定範囲に画像が張りつくというものです。

他のＰＣで開くとリンクが無いため表示できません。
画像を貼り付けると同時にリンクを外して、画像として貼り付けておくことができますか？

今作成したマクロです。

Sub 図の挿入()
Const foldnm = "C:\Users\画像\"
Dim org As Range

'1
Set org = Range("b7:k31")
On Error Resume Next
With ActiveSheet.Pictures.Insert(foldnm & Range("n3").Value & ".jpg")

.Left = org.Left
.Top = org.Top
.Width = org.Width
.Height = org.Height

End With


'2
Set org = Range("b37:k61")
On Error Resume Next
With ActiveSheet.Pictures.Insert(foldnm & Range("n4").Value & ".jpg")


.Left = org.Left
.Top = org.Top
.Width = org.Width
'.Height = org.Height

End With


'3
Set org = Range("b70:k94")
On Error Resume Next
With ActiveSheet.Pictures.Insert(foldnm & Range("n5").Value & ".jpg")


.Left = org.Left
.Top = org.Top
.Width = org.Width
.Height = org.Height

End With

On Error GoTo 0




End Sub

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/03/14 18:34

こんにちは。

現行の貼り付けられた画像に関してのリンクを取ることは分かりませんでしたが、Pictures.Insertには、リンクがついたままの状態で、埋め込みされます。そこで、AddPicture を使えばよいと思います。

xpression.AddPicture(FileName, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
expression　は、Shapes オブジェクト
FileName　 文字列型 (String) の値を指定
LinkToFile　長整数型 (Long) の値を指定。True は、グラフィック ファイルとのリンク
　　　False の場合、図は独立したファイルのコピー

SaveWithDocument　長整数型 (Long) の値を指定。Trueは、リンクが設定された図は、それが挿入された文書と共に保存さる。Falseの場合、文書内のリンク情報だけを格納します。
　※引数 LinkToFile に False を設定する場合、この引数には True を設定する必要があり。

Left, Top　　　単精度浮動小数点数型
Width, Height

添付画像は、埋め込みのリンクのあるなしを調べたものです。

'---------------
Sub PictureEnter()
　Dim arRng As Variant
　Dim Lf As Single, Tp As Single, Wd As Single, Ht As Single
　Dim FileName As String
　Dim i As Long
　Const PICFOLD = "C:\Users\Wendy\Pictures\"
'
　arRng = Array("B7:K31", "B37:K61", "B70:K94")
　
　For i = 0 To UBound(arRng)
　 FileName = PICFOLD & ActiveSheet.Cells(i + 3, "N") & ".jpg"
　With ActiveSheet.Range(arRng(i))
　 Lf = .Left
　 Tp = .Top
　 Wd = .Width
　 Ht = .Height
　 Set ret = ActiveSheet.Shapes.AddPicture(FileName, _
　　　　　False, _
　　　　　True, _
　　　　　Lf, Tp, Wd, Ht)
　End With
　Next i
End Sub

この回答へのお礼

希望通りのことができました！！
すごいです！！！
わかりやすく、簡単にして頂きありがとうございました。

お礼日時：2015/03/16 15:58