Soru Öğrenci İzin Kimlik Kartları İçin Resim Çağırma

[Turan61]

Arkadaşlar yardıma ihtiyacım var

“Makro İçerebilen Excel Çalışma Sayfası (.xlsm)” kitabımda 2 sayfa bulunmaktadır. Biri kimlik bilgilerinin bulunduğu, diğeri de bilgi çağırma ve çıktı almak için kullanılan sayfa
Öğrenci kimlik bilgilerini çağırmak için kullanılan sayfada 10 adet basım için kimlik kartı bulunmaktadır. (Bir satırda 2, Bir sütunda 5, toplam 10 adet kimlik kartı)
B5 yazmış olduğum öğrenci okul numarası ile F2’ye, J5 yazmış olduğum öğrenci okul numarası ile N2’ye,
B12 yazmış olduğum öğrenci okul numarası ile F9’a, J12 yazmış olduğum öğrenci okul numarası ile N9’a,
B19 yazmış olduğum öğrenci okul numarası ile F16’ya, J19 yazmış olduğum öğrenci okul numarası ile N16’ya,
B26 yazmış olduğum öğrenci okul numarası ile F23’e, J26 yazmış olduğum öğrenci okul numarası ile N23’e,
B33 yazmış olduğum öğrenci okul numarası ile F30’a, J33 yazmış olduğum öğrenci okul numarası ile N30’a excel sayfamın kayıtlı olduğu klasörün içinden numaralandırılmış resimleri çağırmasını istiyorum.

Not: Kişi bilgileri formülle çağrılmış yalnız dosyadan çoklu resim çağrılmak istenmektedir. Dosya konumu herhangi bir yer olabilir. (excel dosyasının bulunduğu klasör)

 

[Turan61]

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [B5]) Is Nothing Then Exit Sub

'Hata Kontrolü
On Error GoTo Çıkış

'Resimleri Sil
'ActiveSheet.Pictures.Delete

'Resim Yolunun Bulunması
Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("B5") & ".jpg"

'Resmi Oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resmi Boyutlandır
With Range("F2")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With

Çıkış:
End Sub

Bu kodu yukarıdaki soruma nasıl uyarlayabilirim

 

[mahmut011]

Sub resimgetir() 'Kimlik sayfasında makro oluşturabilirsiniz
    ActiveSheet.Pictures.Delete
    Dim ResimYolu As Variant
Dim Resim As Object
For i = 5 To 33 Step 7
For j = 2 To 10 Step 8 ' 2=Bsütunu 10=J sütunu
On Error GoTo son
ResimYolu = ActiveWorkbook.Path & "\Resimler\" & Cells(i, j) & ".jpg" ' dosyanın çalıştığı klasör içinde Resimler klasörü oluşturup resimleri okul numarasıyla isimlendirip klasör içine konulmalı
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
Cells(i, j + 4).Select
With Resim
.ShapeRange.LockAspectRatio = msoTrue 'resmin görüntüsünün bozulmaması için en/boy oranı kilitlenmeli
If .Height < ActiveCell.Height Then
.Height = ActiveCell.Height
End If
If .Width > ActiveCell.Width Then
.Width = ActiveCell.Width
End If
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Resim.Select
Next j
Next i
son:
End Sub

 

[leumruk]

Selamlar,
Basit bir örnek hazırladım. Dosyanıza "image nesneleri" ekledim. Fotoğraf yüklemede daha sağlıklı oluyor.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B5,j5,b12,j12,b19,j19,b26,j26,b33,j33]) Is Nothing Then Exit Sub
adr = ThisWorkbook.Path & "\foto\" 'Klasör yolunu kendinize göre düzenleyiniz.
sor = Dir(adr & Target & ".JPG") 'Fotoğraf adının numara olduğu varsayılmıştır.
yol = adr & sor
deg = Array("B5", "j5", "b12", "j12", "b19", "j19", "b26", "j26", "b33", "j33")
ara = WorksheetFunction.Match(Target.Address(0, 0), deg, 0)
ActiveSheet.OLEObjects("Image" & ara).Object.Picture = LoadPicture("")
If sor <> "" Then
ActiveSheet.OLEObjects("Image" & ara).Object.Picture = LoadPicture(yol)
End If
MsgBox sor, vbOKOnly, " l e u m r u k"
End Sub

 

[Turan61]

teşekkür ederim arkadaşlar

 

[Turan61]

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B5, J5, " & _
"B12, J12, " & _
"B19, J19, " & _
"B26, J26, " & _
"B33, J33")) Is Nothing Then

For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Address).Offset(-3, 4)) Is Nothing Then
pic.Delete
End If
Next pic

PicFile = ThisWorkbook.Path & Application.PathSeparator & "OgrenciResimleri" & Application.PathSeparator & Target.Text & ".jpg"

If Dir(PicFile) = Empty Then
PicFile = ThisWorkbook.Path & Application.PathSeparator & "OgrenciResimleri" & Application.PathSeparator & "No_Photo.jpg"
End If

PicTop = Range(Target.Address).Offset(-3, 4).Top
PicLeft = Range(Target.Address).Offset(-3, 4).Left
PicW = Range(Target.Address).Offset(-3, 4).MergeArea.Columns.Width
PicH = Range(Target.Address).Offset(-3, 4).MergeArea.Rows.Height
Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
End If
End Sub


Sitede arama yaparken öğrenci oturma planı ile ilgili kod buldum onu kendime göre uyarladım.
Yalnız burada sormak istediğim bir soru var.
Resimler için dosya konumu bellirtmek istemiyorum excel dosyamın bulunduğu klasörü kod kendisi bulup algılamasını istiyorum.
Mümkünmüdür?

 

[Tevfik_Kursun]

Merhaba Arkadaş,

ThisWorkbook.Path &

ifadesi zaten kendi bulunduğu klasörden alacak anlamını taşır. Ama bu durumda resimlerle dosyanız kargaşa yaratır diye düşünürüm. Tabi siz bilirsiniz.
Benim hazırladığım dosya da alternatif olsun
İyi çalışmalar

 

[Turan61]

Merhaba Arkadaş,
ifadesi zaten kendi bulunduğu klasörden alacak anlamını taşır. Ama bu durumda resimlerle dosyanız kargaşa yaratır diye düşünürüm. Tabi siz bilirsiniz.
Benim hazırladığım dosya da alternatif olsun
İyi çalışmalar

teşekkürler

 

[Tevfik_Kursun]

Rica ederim,
İyi çalışmalar