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

[tukayf]

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.

 

[ozuberk]

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

 

[tukayf]

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ı.

 

[ozuberk]

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

 

[tukayf]

Hocam çok teşekkürler zihninize sağlık.

 

[ozuberk]

Rica ederim. Kolay gelsin.