Klasörden Sıralı Resim Alma

[HitMan]

Merhaba,

Örnek dosyamda görülen 'Malzeme Adı' ile aynı dosya adındaki C:\Resimler klasöründeki x boyutta ki resimlerin otomatik olarak 'Resim' sütunuda ki karşılığına 100x100 piksel boyutunda gelmesini isteiyorum. Böyle bir şey mümkünmüdür?
Forumda arama yaptım örneklerde makrolar var ancak genelde personel kayıtları ile ilgili, sıralı liste ile resim alma gibi bir şey yoktu onun için sormak durmunda kaldım.

Teşekkür ederim.

 

[ozgretmen]

Dosyanızı 2003 formatında gönderir misiniz ?

 

[HitMan]

.xls olarak gönderiyorum.

 

[Necdet]

Merhaba,

Doğru anladıysam, aşağıdaki kodların ilgili sayfanın kod bölümünde olmalı.

B sütunu değişince ilgili resim gelir. Siz kod adına göre resimleri oluşturduysanız aşağıdaki koyu satırı silin bir sonraki satırı kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double
[B][COLOR=red]ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"[/COLOR][/B]
'ResimDosya = "C:\Foto" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)
With Cells(Target.Row, Target.Column - 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With
With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With
Set p = Nothing
End Sub

 

[HitMan]

Oldu teşekkür ederim.

 

[1Al2Ver]

Kırmızı satırı sildim dosya ismi ile kod aynı oluyor.

If Dir(ResimDosya) = "" Then

satırı ile ilgili

Run Time Error 13 hatası alıyorum.

Merhaba

Sildiğiniz satırın yerine aşağıdaki kodu, başındaki tırnak (') işaretini kaldırp yazarak denermisiniz

'ResimDosya = "C:\Foto" & "\" & Target.Offset(0, 1).Value & ".jpg"

 

[HitMan]

Mesajımı editledim ama sanırım geç kaldım halloldu çok teşekkür ederim.

 

[efem67]

Sayın hocam bu kodda ilgili sayfada bir hücrede( örn: R6 Hücresine bu hücre birleştirilmiş bir hücre ) resimi getirmek istersek kodda nereyi değiştireceğiz.
Ayrıca resim değişikliği olacağından bir önceki resiminde silinmesi gerekmekte.
şimdiden sonsuz teşekkürler
düşeyara ile R14 den bilgiler geliyor ancak istediğim R6 Hücresine Resim getirmek


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [R14:R14]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double
ResimDosya = "C:\Users\HP\Desktop\EMFD LISANS FISI\Resimler" & "\" & Target.Value & ".jpg"
'ResimDosya = "C:\Users\HP\Desktop\EMFD LISANS FISI\Resimler" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)
With Cells(Target.Row, Target.Column - 1)
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

 

[kneehot]

selamlar. b sutunundaki hücrelere direk veri girince resim geliyor fakat düşeyara tarzı bır formulle veri girince resim cıkmıyor.formul ıle bu makronun calısabılmesı saglanabılırmı.yardımlara tesekkurler.

 

[BedriA]

Merhaba,

Doğru anladıysam, aşağıdaki kodların ilgili sayfanın kod bölümünde olmalı.

B sütunu değişince ilgili resim gelir. Siz kod adına göre resimleri oluşturduysanız aşağıdaki koyu satırı silin bir sonraki satırı kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double
[B][COLOR=red]ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"[/COLOR][/B]
'ResimDosya = "C:\Foto" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)
With Cells(Target.Row, Target.Column - 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With
With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With
Set p = Nothing
End Sub

Çok teşekkürler.
Tesadüfen rastladığım bu kod işime çok yaradı.
Acaba bunu sadece a1:a10 hücrelerine resim gelecek şekilde nasıl ayarlayabiliriz?

 

[BedriA]

Necdet Hocam,

Bir de eklenen bu resimleri bir butona atanacak kodlar ile silmek mümkün mü?