Bağlantılı resim görüntülenemiyor..." hatası

[Feylosof]

Merhaba
Sayın @halit3 ün bir çalışmasından aldığım kodu kendi dosyama uyarladım. Kod gayet güzel çalışıyor ve resmi istediğim satır ve sütuna getiriyor. Ancak Dosyayı kapatıp tekrar açtığımda resim gözükmüyor ve "Bağlantılı resim görüntülenemiyor..." hatası veriyor. Kodu nasıl revize etmeliyiz ki yüklenen fotoğraf kalıcı hale gelsin.
Şimdiden teşekkürler ediyorum.
Dim Resim As OLEObject
Dim Adres As Range
yer = ThisWorkbook.Path & "\Resimler\" & "\" & Range("J" & ActiveCell) & ".jpg"
SavePicture Image1.Picture, yer
sat = ActiveCell
sut = "J"

Set Adres = Range(Cells(sat + 1, sut).Address)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
'Picture.Delete
'End If

Next Picture

ad = ActiveSheet.Pictures.Insert(yer).Name

'ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
Kill yer

 

[Feylosof]

Dim Resim As OLEObject
Dim Adres As Range
yer = ThisWorkbook.Path & "\Resimler\" & "\" & Range("J" & ActiveCell) & ".jpg"
SavePicture Image1.Picture, yer
sat = ActiveCell
sut = "J"

Set Adres = Range(Cells(sat + 1, sut).Address)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
'Picture.Delete
'End If

Next Picture

ad = ActiveSheet.Pictures.Insert(yer).Name

'ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
Kill yer

Konu günceldir efendim.

 

[Korhan Ayhan]

Forumda picture yazarak arama yaparsanız onlarca örnek koda erişebilirsiniz.

 

[Feylosof]

Kıymetli @Korhan Ayhan üstadım. Çok haklısınız forumda mebzul miktarda örnek kodlar var epeyce araştırdıktan sonra bu koda rastladım ve işimi tam istediğim şekilde gerçekleştiriyor tek eksik resmin kalıcı olmaması. Zira resmi, sayfaya imaj nesnesinden aktarmaktadır. Biraz daha kurcalayayım o halde. Çok teşekkürler.

 

[Feylosof]

Ne yaptıysam resimleri kalıcı hale getiremedim. Kod bilgim malesef çok zayıf kaldı. Aramalardan bir sonuç elde edemedim. @Korhan Ayhan hocam.

 

[halit3]

Bu kodu bir dene

Private Sub CommandButton1_Click()


Dim Adres As Range
Dim s1
Set s1 = Sheets(ActiveSheet.Name)

sat = ListBox1.ListIndex + 2
sut = "j"
Set Adres = Range(Cells(sat, sut).Address)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer2 = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

If yer2 = Adres.Address Then
Picture.Delete
End If
End If
Next Picture

Dosya = ThisWorkbook.Path & "\Resimler\" & TextBox2.Text & ".jpg"

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
yer = ThisWorkbook.Path & "\Resimler\" & TextBox2.Text & ".jpg"
Else
yer = ThisWorkbook.Path & "\Resimler\YOK.jpg"
End If


ad = ActiveSheet.Pictures.Insert(yer).Name

'ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

MsgBox "TAMAM", vbInformation, "TEK RESİM İŞLEME"

End Sub

 

[Feylosof]

@halit3 Üstadım oldu. Tam istediğim gibi. Emeğinize sağlık. Minnettarım.