Çözüldü Klasörden resim ve resim adını çağırma

Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Kod:
Sub resim_71()
Son = 3
ReDim uzanti(Son)
'uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
'uzanti(3) = ".gif"

With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With

Klasor = "H:\Resimler\"

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 2 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
deg = 0
For j = 1 To Son
If fso.FileExists(Klasor & isim & uzanti(j)) = True Then
Set pc = ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)) '<-- dikkat
With pc '<---
.Top = Cells(i, 4).Top + 2
.Left = Cells(i, 4).Left + 2
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = Cells(i, 4).Height - 4
.ShapeRange.Width = Cells(i, 4).Width - 4
End With
deg = 1

Exit For
End If
Next
Next
End Sub
Merhabalar. Yukardaki kod ile B sütununda yazılan isme göre D sütununa resimleri klasörden çağırabiliyorum. Ancak M sütununa da resim dosyalarının adlarını çağırmak istiyorum.
Acelesi olduğu için nette ve forumda araştırarak çözüm yoluna gidemiyorum maalesef.
 
Katılım
10 Ağustos 2004
Mesajlar
290
Excel Vers. ve Dili
Excel 2021 - Türkçe
Merhaba aşağıdaki kodu deneyin.

Sub resim_72()
Application.ScreenUpdating = False

Dim Dosya As String, Satir As Integer, Yol As String
Yol = "H:\Resimler\"
Dosya = Dir(Yol & "*jpg*")
Satir = 1
While Dosya <> ""
Range("M" & Satir) = Dosya
Satir = Satir + 1
Dosya = Dir()
Wend
End Sub
 
Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Hocam yanıt için teşekkür ederim. Bu kod tüm klasördeki resimleri listeliyor. Yapmak istediğim resmi çağırıp aynı zamanda diğer sütuna resmin adını ve uzantısını çağırmak.
Yani tüm klasörü çağırmasın B sütununda yazan TC sicil her neyse onun karşılığı olan resmi getirmesi ve diğer sütuna o resmin adı ve uzantısını yazması.
 
Katılım
10 Ağustos 2004
Mesajlar
290
Excel Vers. ve Dili
Excel 2021 - Türkçe
Merhaba aşağıdaki kodu deneyin.

Sub resim_71()
Son = 3
ReDim uzanti(Son)
'uzanti(1) = ".bmp"
uzanti(2) = ".png"
'uzanti(3) = ".gif"

With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With

Klasor = "H:\Resimler\"

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 2 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
deg = 0
For j = 1 To Son
If fso.FileExists(Klasor & isim & uzanti(j)) = True Then
Cells(i, 5) = isim & uzanti(j)
Cells(i, 6) = Klasor
Set pc = ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)) '<-- dikkat
With pc '<---
.Top = Cells(i, 4).Top + 2
.Left = Cells(i, 4).Left + 2
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = Cells(i, 4).Height - 4
.ShapeRange.Width = Cells(i, 4).Width - 4
End With
deg = 1

Exit For
End If
Next
Next
End Sub
 
Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Hocam çok teşekkürler zihninize sağlık.
 
Üst