İsme göre değişen resim çağırma hata

[nomercy99]

Merhabalar arkadaşlar;

aşağıdaki kodlarla resimleri çağırıyoum ama verilen yolda resim bulunamadığında resim siliniyor ve geri gelmiyor.Nasıl bir düzeltme yapmam lazım

''''Sayfa içerisine yazılacak kod'''
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Dim satir As Long
If Not Intersect(Target, Range("A1:A60000")) Is Nothing Then
satir = Target.Row
yol = Range("B" & satir).Value
resim_degistir
End If
End Sub


'''''Modül içerisine yazılacak kod'''''''''''''''''''''''''''''''''''''''''''''
Global yol As String
Sub resim_degistir()
On Error Resume Next
strPic = "Resim 661"
Set shp = ActiveSheet.Shapes(strPic)
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
If yol = "" Then Exit Sub
ActiveSheet.Shapes(strPic).Delete
Set shp = ActiveSheet.Shapes.AddPicture(yol, msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic


şimdiden yardımlarınız için teşekkürler

 

[nomercy99]

Hocalarımdan yardım edecek olan yok mudur acaba?

 

[Levent Menteşoğlu]

Aşağıdaki kırmızı renkli eklemeleri yapın.

''''Sayfa içerisine yazılacak kod'''
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Dim satir As Long
If Not Intersect(Target, Range("A1:A60000")) Is Nothing Then
satir = Target.Row
yol = Range("B" & satir).Value
resim_degistir yol
End If
End Sub

'''''Modül içerisine yazılacak kod'''''''''''''''''''''''''''''''''''''''''''''
Global yol As String
Sub resim_degistir(yol)
On Error Resume Next
strPic = "Resim 661"
Set shp = ActiveSheet.Shapes(strPic)
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
If yol = "" Then Exit Sub
ActiveSheet.Shapes(strPic).Delete
Set shp = ActiveSheet.Shapes.AddPicture(yol, msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic

 

[nomercy99]

Aşağıdaki kırmızı renkli eklemeleri yapın.

Hocam çok teşekkürler ilginiz için ama sorunum çözülmedi malesef

Sayfada Aşağıdaki gibi örnek üzerinde çalışıyorum.Örneğin 8697353404221.jpg nolu resimi belirtilen yolda bulamadığı zaman resim komple siliniyor ve tekrar başka resim açılmıyor.Onu nasıl çözebiliriz?Resim bulunamadığı zaman örneğin benim klasöre atacağım "eksikresim.jpg" isimli dosyayı açabilir mi?Yada bir şey açmasa da olur ama resim silindiği zaman makro devam etmiyor.Tekrar elle resim 661 yi eklemem gerekiyor



8697353524394 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353524394.jpg
8697353390128 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353390128.jpg
8697353421143 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353421143.jpg
8697353387104 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353387104.jpg
8697353243677 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353243677.jpg
8697353095764 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353095764.jpg
8697353404221 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353404221.jpg
8697353199998 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353199998.jpg
8697353218668 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353218668.jpg
8697353420511 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353420511.jpg
8697353533433 C:\Users\ozgun\OneDrive\Sipariş resimleri\8697353533433.jpg

 

[Levent Menteşoğlu]

Aşağıdaki satıra da koyu renkli ilaveyi yaparak deneyin.

If dir(yol) = "" Then Exit Sub

 

[nomercy99]

Aşağıdaki satıra da koyu renkli ilaveyi yaparak deneyin.

Çok teşekküer ederim hocam,elleriniz dert görmesin.Sağlıcakla kalın

 

[nomercy99]

Aşağıdaki satıra da koyu renkli ilaveyi yaparak deneyin.

Hocam kusura bakmayın tekrar yazıyorum ama bir konuda daha yardımınıza ihtiyacım var.

Bu makro da resim en ve boylarını uzatıyor mevcut resime göre,uzatmadan en boy oranını koruyacak şekilde bir makro eklememiz mümkün müdür?

Şimdiden yardımlarınız için çok teşekkür ederim.

 

[Levent Menteşoğlu]

Hocam kusura bakmayın tekrar yazıyorum ama bir konuda daha yardımınıza ihtiyacım var.

Bu makro da resim en ve boylarını uzatıyor mevcut resime göre,uzatmadan en boy oranını koruyacak şekilde bir makro eklememiz mümkün müdür?

Şimdiden yardımlarınız için çok teşekkür ederim.

Aşağıdaki değişkenlere sabit sayılar yazarak deneyin.

h = .Height
w = .Width

 

[nomercy99]

Aşağıdaki değişkenlere sabit sayılar yazarak deneyin.

h = .Height
w = .Width

Hocam çok teşekkür ederim ama sorunum çözülmedi,evet belirttiğiniz gibi yaptığımda resmin boyutunu belirleyebiliyorum ama ben "height" sabit kalıp "width" in değiken olmasını istiyorum.Yani orjinal resimdeki en boy oranı korunsun istiyorum.Bu değişkenlerden birisine yada ikisine birden sayı girdiğimde yine en boy oranı korunmuyor.Değer girilmeyen,mevcutta bulunan Resim 661 in boyutunda,değer girilen benim girdiğim boyutta geliyor

 

[Levent Menteşoğlu]

O zaman aşağıdaki bir mantık deneyin. H için 500 değerini kendinize göre değiştirin. Buda olmazsa resimleri bir image nesnesi üzerinden çağırmak daha mantıklı olacaktır.

Set shp = ActiveSheet.Shapes(strPic)
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With

h1=500
w1=w*(h1/h)

If yol = "" Then Exit Sub
ActiveSheet.Shapes(strPic).Delete
Set shp = ActiveSheet.Shapes.AddPicture(yol, msoFalse, msoTrue, l, t, w1, h1)
shp.Name = strPic

 

[nomercy99]

O zaman aşağıdaki bir mantık deneyin. H için 500 değerini kendinize göre değiştirin. Buda olmazsa resimleri bir image nesnesi üzerinden çağırmak daha mantıklı olacaktır.

Malesef hocam yine olmadı.Ben resimlerin çözünürlüklerinin oran olarak aynı kalmasını istiyorum.Bu şekilde resimleri uzatıyor.

Aslında image nesnesi üzerinden çağırıyorum.Böyle olunca da gelen resimler mevcut image ile birebir aynı boyutta oluyor.Yine resimler uzuyor.

Sizin dediğiniz farklı bir yol mudur?

 

[nomercy99]

O zaman aşağıdaki bir mantık deneyin. H için 500 değerini kendinize göre değiştirin. Buda olmazsa resimleri bir image nesnesi üzerinden çağırmak daha mantıklı olacaktır.

Bir kaç yerden parçala birleştir ile halletim hocam aşağıdaki gibi.Daha önceki destekleriniz için çok teşekkür ederim tekrardan.Saygılar.

Global yol As String
Sub resim_degistir(yol)
On Error Resume Next
strPic = "Resim 1"
Set shp = ActiveSheet.Shapes(strPic)


If Dir(yol) = "" Then Exit Sub
ActiveSheet.Shapes(strPic).Delete
Set shp = ActiveSheet.Shapes.AddPicture(yol, msoFalse, msoTrue, Left:=300, Top:=100, Width:=-1, Height:=-1)
With Shape

       shp.ShapeRange.LockAspectRatio = msoTrue
       shp.Left = ActiveSheet.Range("A1").Left
       shp.Top = ActiveSheet.Range("A1").Top
       shp.Width = ActiveSheet.Range("A1:B1").Width
       shp.Height = ActiveSheet.Range("A1:B1").Height
End With

shp.Name = strPic
End Sub

 

[Levent Menteşoğlu]

Malesef hocam yine olmadı.Ben resimlerin çözünürlüklerinin oran olarak aynı kalmasını istiyorum.Bu şekilde resimleri uzatıyor.

Aslında image nesnesi üzerinden çağırıyorum.Böyle olunca da gelen resimler mevcut image ile birebir aynı boyutta oluyor.Yine resimler uzuyor.

Sizin dediğiniz farklı bir yol mudur?

Sizin kodlamada sayfa üzerine resim bir nevi yapıştırılıyor. Image nesnesi ile activex denetimlerindeki resim nesnesini kasdetmiştim.