ada göre resim ekleme

[euphrates55]

bu aralar fazlasıyla forumu işgal ettiğimin farkındayım ama excelin sınırsızlığı beni bu hallere sokuyor. sorum ise şöyle...
V3 hücresine yazdığım isime göre, excel dosyamın olduğu dizin içersindeki haritalar klasöründen aynı isimdeki resmi K15 hücresine ve taşmıyacak şekilde eklemek için aşağıdaki kod doğru mu acaba?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim res As String
Dim a As Shape
Dim k15 As Range
If Target = "" Or Target.Address <> "$v$3" Then Exit Sub
If Target.Count > 1 Then Exit Sub
Set k15 = Range("k15")
For Each a In Shapes
a.Delete
Next a
k15.ClearContents
res = ThisWorkbook.Path & "\" & Target.Value & ".jpg"
If Dir(res) = "" Then
k15 = "RESİM YOK"
Else
With ActiveSheet.Pictures.Insert(res)
.Left = k15.Left
.Top = k15.Top
.Height = k15.Height
.Width = k15.Width
End With
End If
End Sub

 

[muygun]

Merhaba;
Mevcut kodları silin ve Sayfa1 sayfasının kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("Sayfa1").Select
yol = ThisWorkbook.Path & "\haritalar\"

Rem aralıktaki resmi sil
Set Alan = Range("k15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(3, "v").Value & ".jpg") <> "" Then
dosya = "\" & Cells(3, "v").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
End Sub

Kodlarını yerleştirip deneyin.
İyi çalışmalar.

 

[euphrates55]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [v3]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim resimyolu As Variant
Dim resim As Object
resimyolu = ActiveWorkbook.Path & "\" & Range("v3") & ".jpg"
Set resim = ActiveSheet.Pictures.Insert(resimyolu)
With Range("k15:s15")
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With
çıkış:
End Sub

tam yazarken siz de cevaplamışsınız. teşekkürler. ben de sağdan soldan kopya çekerek istediğimin çoğunu yaptım. benim yazdığımda iki sorunla karşılaştım. birincisi eklenen resim hücreden taşıyor. bu resim boyutuylamı alakalı olur ve bunun yüksekliği ya da genişliği ile oynatarak tam sığdırmak mümkünmüdür? bir diğer sorunum ise her isim değişiminde silinen resim ile makro atadığım şekil de siliniyor. bunu halletmenin bir yolu var mıdır?

diyecekken sizin kodunuzda 2. sorun hallolmuş oldu. makro atanan şekil silinmiyor. fakat bu sefer de resim hücreyi tam doldurmadı. bunun oranı değişse de hücreye tam sığsa gibi bir özelliği var mı ve bir de k15 dedim ama düşünemedim aslında k15:s15 aralığına sığdırmak için sanırım burasını düzeltmek gerekli, With Cells(15, "k") kısmını nasıl yazmalıyım.


ekleme: resimlerden birisi sanırım absürt bir boyutu vardı ki hücre dışına taştı ve diğer isim seçtiğimde bu resim silinememiş oldu. bilgi için yazmak istedim.

 

[muygun]

Merhaba;
Eki deneyin ve kendi dosyanıza uyarlayın.
(K15:S15 aralığındaki hücreler birleştirildi. , silme işlemi için bu alan baz alındı)
İyi çalışmalar.

 

[euphrates55]

günaydın, kendi dosyama uyarladım ve yine hücreden taşıyor maalesef. resime hücre içerisinde belli bir boyut verme şansımız oluyor mu, tabi en boy oranı kilitli olmayacak şekilde. bir de olmayan resim olduğunda hata veriyor. bunu da engelleme şansımız varsa sevinirim. resim yoksa boş bıraksın ama hata vermesin. yükseklik : 11,3 cm ve genişlik:16,65 cm oluyor.

 

[muygun]

kodların ilk satırından sonra;
On Error Resume Next
ekleyerek deneyin.
Taşma meselesine gelince;
Denemelerimde böyle bir sorunla karşılaşmadım. (yada olağan dışı boyutta bir resim denemedim. Gerekirse bu resimleri Photoshop yada paint ile küçültün.)

 

[euphrates55]

Sub seçili_hücreye_resim_ekle()
dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
Set alan = Range("k15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Cells(15, "k").Select
Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Cells(1, 1).Select
End Sub

bu kod ile elle resim seçiyorum ve tam oturuyor. buna uyarlama şansımız var mı? ne yaptığı hakkında bilgim olsa ben yapacağım ama bilmiyorum. size zahmet olmazsa bakabilirmisiniz