Klasörden Resim Çağırma

[mcetinkaya65]

Hazırladığım Programda Resimler klasörden excel üzerindeki form sayfasında E6 hücresinde yazan ismin resmini birleştirilmiş olan T6 hücresine getirmemiz mümkün mü?Form Sayfasındaki veriler indisle Veriler sayfasından çağırıyoruz.

Saygılarımla..

 

[halit3]

Bu kodu bir modülün içine kopyala ve açılan liste kutusuna mause ile sağ tıkla makro ata seçeneğinden Resimlerekle2 seç ve kodu çalıştır.

Kod:

Sub Resimlerekle2()

Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Set Adres = s1.Range(s1.Cells(6, "t"), s1.Cells(10, "x"))
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer = s1.Range(s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column), s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column))

If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"

For j = 1 To 11
Dosya2 = ThisWorkbook.Path & "\Resimler\" & s1.Cells(6, "e") & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Exit For
End If
Next

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Else
Dosya = ThisWorkbook.Path & "\Resimler\ResimYok.jpg"
End If

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2

End If

End Sub

 

[mcetinkaya65]

İlginize Teşekkür ederim.
Allah Razı Olsun.

 

[halit3]

Teşekkürler iyi çalışmalar

 

[mcetinkaya65]

Selmün aleyküm.
Halit3 ün makrosuyla yukardaki sorunu çözdük Allah Razı olsun. İnsan olarak gözümüz doymuyor. Form sayfasına makrolu öyle bir büton ekleyelim ki yazdır dediğimzde veriler sayfasından verileri form sayfasına resimle beraber çekip veriler sayfasının B stunundaki isimlere form dolurması mümkün mü. (toplu yazdır butonu)
Saygılarımla

 

[halit3]

Aleyküm Selam
Kod

Sub yazdır()

Worksheets("Form").Cells(1, 1).Value = 0
For i = 4 To Worksheets("Veriler").Cells(Rows.Count, "b").End(3).Row
Worksheets("Form").Cells(1, 1).Value = Worksheets("Form").Cells(1, 1).Value + 1

Call Resimlerekle2

Worksheets("Form").PageSetup.PrintArea = "$B$1:$X55"
Worksheets("Form").PrintOut Copies:=1, Collate:=True
Next i
MsgBox "işlem tamam"
End Sub

 

[mcetinkaya65]

Kul daralmayınca hızır yetişmezmiş.
Allah Razı Olsun...