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

Katılım
24 Temmuz 2019
Mesajlar
413
Excel Vers. ve Dili
EXCEL 2010 TÜRKÇE
Altın Üyelik Bitiş Tarihi
25-12-2023
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
 
Son düzenleme:
Katılım
24 Temmuz 2019
Mesajlar
413
Excel Vers. ve Dili
EXCEL 2010 TÜRKÇE
Altın Üyelik Bitiş Tarihi
25-12-2023
Kod:
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Forumda picture yazarak arama yaparsanız onlarca örnek koda erişebilirsiniz.
 
Katılım
24 Temmuz 2019
Mesajlar
413
Excel Vers. ve Dili
EXCEL 2010 TÜRKÇE
Altın Üyelik Bitiş Tarihi
25-12-2023
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.
 
Katılım
24 Temmuz 2019
Mesajlar
413
Excel Vers. ve Dili
EXCEL 2010 TÜRKÇE
Altın Üyelik Bitiş Tarihi
25-12-2023
Ne yaptıysam resimleri kalıcı hale getiremedim. Kod bilgim malesef çok zayıf kaldı. Aramalardan bir sonuç elde edemedim. @Korhan Ayhan hocam.
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu bir dene
Kod:
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
 
Katılım
24 Temmuz 2019
Mesajlar
413
Excel Vers. ve Dili
EXCEL 2010 TÜRKÇE
Altın Üyelik Bitiş Tarihi
25-12-2023
@halit3 Üstadım oldu. Tam istediğim gibi. Emeğinize sağlık. Minnettarım.
 
Üst