Makro bitene kadar resim değişmiyor

[erkan16]

Forumlarda aradım ancak bulamadım. yardımcı olursanız sevinirim. hücredeki değer manuel olarak değiştiğinde resim değişiyor ancak yazdığım makroya bağlı olarak değişmiyor. öğreci kimlik kartlarını bilgiler sayfasındaki verilere bağlı olarak her sayfada 5 öğrencinin kimliği olmak üzere belli bir sayıdaki öğrencileri arka arkaya yazdırmak istiyorum. ilk sayfadan sonra resimler değişmiyor.

 

[erkan16]

kimse ilgilenmiyor galiba

 

[halit3]

Forumlarda aradım ancak bulamadım. yardımcı olursanız sevinirim. hücredeki değer manuel olarak değiştiğinde resim değişiyor ancak yazdığım makroya bağlı olarak değişmiyor. öğreci kimlik kartlarını bilgiler sayfasındaki verilere bağlı olarak her sayfada 5 öğrencinin kimliği olmak üzere belli bir sayıdaki öğrencileri arka arkaya yazdırmak istiyorum. ilk sayfadan sonra resimler değişmiyor.

Merhaba resimlerin ne şekilde değiştirdiğinizi yazmamışsınız.

Dosyanın hemen yanında Resimler klasörü olmalı resimlerde bu klasörün içinde olmalı öğrencinin TC numaraları ile resimler olmalı ve öğrencinin numarasına ait hücre değiştiği zaman kod çalışıyor.

kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [F12,F29,F46,F63,F80]) Is Nothing Then Exit Sub
Resim_Adı = Cells(Target.Row - 2, Target.Column)
klasor = ThisWorkbook.Path & "\Resimler\"

ReDim uzanti(5)
uzanti(1) = "jpg"
uzanti(2) = "bmp"

For i = 1 To 2
resimyükle = klasor & Resim_Adı & "." & uzanti(Val(i))

If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then
If Target.Row = 12 Then
Image1.Picture = LoadPicture(None)
Image1.Picture = LoadPicture(resimyükle)
ElseIf Target.Row = 29 Then
Image2.Picture = LoadPicture(None)
Image2.Picture = LoadPicture(resimyükle)
ElseIf Target.Row = 46 Then
Image3Picture = LoadPicture(None)
Image3.Picture = LoadPicture(resimyükle)
ElseIf Target.Row = 63 Then
Image4.Picture = LoadPicture(None)
Image4.Picture = LoadPicture(resimyükle)
ElseIf Target.Row = 80 Then
Image5.Picture = LoadPicture(None)
Image5.Picture = LoadPicture(resimyükle)
End If
Exit For
Else

End If
Next i

End Sub

 

[erkan16]

ilginiz için teşekkür ederim. yukarıda vermiş olduğunuz makroyu denedim ama olmadı. bazı eksiklikleri girdereyim. resimleri C: deki Resimler adında açtığım bir klasörden alıyor. Resimler öğrenci numarası ile isimlendirilmiş ve çağrılırken BİLGİLER sayfasındaki öğrenci numaralarına göre çağrılıyor. öğrenci kimliği sayfasında gizli aa sütununda yolu var. ek dosyanın boyutu büyümesin diye bu klasörü eklemedim. siz üç resimle varsayılan yazıcıyı xps olarak ayarladığınızda ne demek istediğimi anlayacaksınız. 1. resmi (format jpeg) 5 kez kopyalayıp isimlerini 11, 12 ,13 , 14 , 15 yapın. 2. resmi (format jpeg) 5 kez kopyalayıp isimlerini 16, 17 , 18, 19 20 yapın. 3. resmi (format jpeg) 5 kez kopyalayıp isimlerini 21 22 23 24 25 yapın. öğrenci bilgileri sayfasında yazdır möakrosunu çalıştırdığınızda ilk yazdırılacak öğrenci sırasını soruyor. örneğin3 girdiniz. bilgiler sayfasındaki 3. sıradaki öğrenciden yazdırmaya başlar. ok dediğinizde son sırayı sorar 15 girip ok dediğinizde 15. sıradaki öğrenciye kadar yazdırmaya çalışır. ilk 5 öğrenci güzel. resimleri de geliyor. sonraki yazdırma sayfalarında ise hep bu ilk 5 öğrencinin resimleri geliyor. yazdırma bitiyor yani makro bitiyor son öğrencilerin resimleri sayfada yerini alıyor. ama çıktılarda resimler hep aynı

 

[halit3]

fotoğraflara ait image nesnelerini silin kod kendisi resim nesnesi oluşturacaktır.

kod

Sub yazdır2()

klasor = "C:\Resimler\"

sat = 9
sut = 6
For j = 3 To Worksheets("BİLGİLER").Cells(Rows.Count, "f").End(3).Row Step 5



kimlik1 = Worksheets("BİLGİLER").Cells(j, "d").Value
kimlik2 = Worksheets("BİLGİLER").Cells(j + 1, "d").Value
kimlik3 = Worksheets("BİLGİLER").Cells(j + 2, "d").Value
kimlik4 = Worksheets("BİLGİLER").Cells(j + 3, "d").Value
kimlik5 = Worksheets("BİLGİLER").Cells(j + 4, "d").Value

Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(12, "f").Value = kimlik1
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(29, "f").Value = kimlik2
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(46, "f").Value = kimlik3
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(63, "f").Value = kimlik4
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(80, "f").Value = kimlik5



For i = 1 To 5
'Cells(sat, sut + 2).Select
Set Adres = Range(Cells(sat, sut + 2), Cells(sat + 4, sut + 3))
'MsgBox Adres.Address
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then

Picture.Delete
Exit For
End If
End If
Next Picture

isim = Cells(sat + 3, sut).Value


'On Error Resume Next

If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & ".jpg") = True Then
ActiveSheet.Pictures.Insert(klasor & isim & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top
Selection.Left = Adres.Left + 3
Selection.ShapeRange.Height = Adres.Height - 2
Selection.ShapeRange.Width = Adres.Width - 2
'MsgBox j
End If
sat = sat + 17
Next i
Application.Wait (Now + TimeValue("0:00:2"))

Worksheets("ÖĞRENCİ KİMLİĞİ").PageSetup.PrintArea = "$A$1:$V$85"
Worksheets("ÖĞRENCİ KİMLİĞİ").PrintOut Copies:=1, Collate:=True

sat = 9
sut = 6
Next j
MsgBox "işlem tamam"
End Sub

 

[halit3]

Veya bu kodu kullan
kod:

Option Explicit

Sub yazdır3()

Application.ScreenUpdating = False
Dim yer, j, i
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim klasor As String
Dim Resim_Adı As String
Dim sat, sut

Dim s1
Set s1 = Sheets(ActiveSheet.Name)
klasor = "C:\Resimler\"

sat = 9
sut = 6
For j = 3 To Worksheets("BİLGİLER").Cells(Rows.Count, "f").End(3).Row Step 5


Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(12, "f").Value = Worksheets("BİLGİLER").Cells(j, "d").Value
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(29, "f").Value = Worksheets("BİLGİLER").Cells(j + 1, "d").Value
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(46, "f").Value = Worksheets("BİLGİLER").Cells(j + 2, "d").Value
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(63, "f").Value = Worksheets("BİLGİLER").Cells(j + 3, "d").Value
Worksheets("ÖĞRENCİ KİMLİĞİ").Cells(80, "f").Value = Worksheets("BİLGİLER").Cells(j + 4, "d").Value


For i = 1 To 5

Resim_Adı = Cells(sat + 3, sut).Value & ".jpg"

Set Adres = Range(Cells(sat, sut + 2), Cells(sat + 4, sut + 3))


Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If Not Intersect(Range(yer), Adres) Is Nothing Then

Picture.Delete
Exit For
End If
End If
End If
Next Picture



If CreateObject("Scripting.FileSystemObject").FileExists(klasor & Resim_Adı) = True Then
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)


With Yeni_Resim
.Top = Adres.Top + 1
.Left = Adres.Left + 1
.Height = Adres.Height - 2
.Width = Adres.Width - 1
.Object.PictureSizeMode = fmPictureSizeModeStretch 'fmPictureSizeModeClip 'fmPictureSizeModeZoom '
End With
Yeni_Resim.Object.Picture = LoadPicture(klasor & Resim_Adı)
End If

sat = sat + 17
Next i

Application.Wait (Now + TimeValue("0:00:01"))

Worksheets("ÖĞRENCİ KİMLİĞİ").PageSetup.PrintArea = "$A$1:$V$85"
Worksheets("ÖĞRENCİ KİMLİĞİ").PrintOut Copies:=1, Collate:=True
sat = 9
sut = 6

Next j
MsgBox "işlem tamam"
Application.ScreenUpdating = True

End Sub

 

[erkan16]

gönderdiğiniz dosya çok işime yaradı. birkaç düzeltmeyle şu an çok iyi çalışıyor. teşekkür ederim. elinize aklınıza sağlık.