Resim yerleştirme

Muhammet Okumuş · 30 Mart 2020

Arkadaşlar merhaba,
Öğretmen olduğum için öğrencilere test hazırlıyorum.
Soruların hepsi dar veya hepsi geniş resim olduğunda yerleştirmeyi yapabiliyorum. Ama sorular geniş ve dar resim olduğunda soruları yerleştiremiyorum.
Dosyaya geniş ve dar resimler koydum kriterleri açıkladım. Burada kurallardan yine bahsedeyim.
1) Öncelikle resimler sayfa dışına taşmayacak.
2) Resimler bir sayfaya 2 geniş 2 dar olarak yerleşecekse
G: Geniş Resim
D: Dar Resim

G
G
D D
veya
D D
G
G
şeklinde yerleşmeli
yani
G
D D
G şeklinde olmalı.

Son sayfa hariç dar soru tek bulunmaalı
G
D
şeklinde olamalı. Son sayfa
G
D şeklinde olabilir
ama
D
G şeklinde olamaz.

Geniş resimden sonra gelen dar resimler aynı satırda olmalı,

Bu kriterlere göre resimleri yerleştirebilir miyiz? İlginize şimdiden teşekkür ederim.

Muhammet Okumuş · 30 Mart 2020

Her hangi bir önerisi olan var mı?

Muhammet Okumuş · 30 Mart 2020

Konu güncel...

Tevfik_Kursun · 30 Mart 2020

Merhaba Arkadaşım,
Öğrencilere uyguladığınız çok resimli sınavlardan bir örnek yükleyin lütfen, inceliyeyim.
İyi çalışmalar

Muhammet Okumuş · 31 Mart 2020

testler - Google Drive

drive.google.com

Dosya boyutları büyük olduğu için burası kabul etmedi.

Linkte pdf ve excel dosyalarını paylaştım. Taslak sayfasında sıralı ve karışık yerleştir kodları yerleştirme yapıyor. Ama sizin klasörü kendiniz göre düzeltmeniz gerekiyor.
Resim_Al makrosunda dosya yolu mevcut.
Set MyPath = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\muhammet\Desktop\fstone")
Bendeki bu şeklide.
Yeni nesil geniş olarak test oluşturma ise dar olarak yerleştiriyor. Sayfalar bende tam olarak yerleşecek şekilde ayarlı sizin bilgisayarınızdaki yazıcıya göre taşmalar veya kısa kalma olabilir.

Yerleştirme işlemi için taslak sayfasının CA:CZ arası sütunlarda formüller mevcut. Bu formülleri kendim oluşturdum. Makrolar ise muhtelif kaynaklardan aldım.

Q tuşuna geniş resim W tuşuna dar resmi ayarlayan kodlar atadım.

halit3 · 31 Mart 2020

Tam olarak anlamadığım için belki bu kod işinizi görür
bu kod önce enine sonrada boyuna ait resimleri getirir kod yerleştirme sayfasında çalışır.

Kod:

Private Sub CommandButton1_Click()
ActiveWindow.ScrollRow = 300
t = 1
Set s2 = Sheets("Yerleştirme")
Set s1 = Sheets("Resim")
ReDim res1(500): ReDim res2(500)
say1 = 0
say2 = 0

Dim Picture As Object
For Each Picture In s2.Shapes

'MsgBox Picture.Type & Chr(10) & Picture.Name
If Picture.Type <> 12 Then
'If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
'Exit Sub
say = s2.Shapes.Count

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height > Picture.Width Then
sat = sat + 1
say1 = say1 + 1
res1(say1) = Picture.Name
End If
End If
Next Picture

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height < Picture.Width Then
sat = sat + 1
say2 = say2 + 1
res2(say2) = Picture.Name
End If
End If
Next Picture

sat1 = 1
sat2 = sat1 + 8
sut1 = 1
sut2 = 10

say3 = 0
For k = 1 To say2


If sat1 > ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + 8
t = t + 1
End If

Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy
s2.Paste Destination:=s2.Range("A" & sat1)
say = s2.Shapes.Count
'MsgBox say
ad1 = s2.Shapes(say).Name
'ad1 = Selection.Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,

s2.Shapes(ad1).OLEFormat.Object.Top = Adres2.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres2.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres2.Height - 4
s2.Shapes(ad1).OLEFormat.Object.Width = Adres2.Width - 4
s2.Shapes(ad1).OLEFormat.Object.Name = "Resim " & k
sat1 = sat1 + 11
sat2 = sat1 + 8
Next k

ekle = 20
sat1 = sat1
sat2 = sat1 + ekle
sut1 = 1
sut2 = 5

For k = 1 To say1

If k Mod 2 = 1 Then
If sat1 > ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + ekle
End If
deg = 0

If sat2 > ActiveSheet.HPageBreaks.Item(t).Location.Row Then
If sat1 < ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat2 = ActiveSheet.HPageBreaks.Item(t).Location.Row - 1
End If
End If

sut1 = 1
sut2 = 5
Else
deg = 1
sut1 = 6
sut2 = 10
End If

Set Adres3 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
s1.Shapes(res1(k)).CopyPicture

s2.Paste Destination:=s2.Range("A" & sat1)

say = s2.Shapes.Count
ad1 = s2.Shapes(say).Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,
s2.Shapes(ad1).OLEFormat.Object.Top = Adres3.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres3.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres3.Height - 4
s2.Shapes(ad1).OLEFormat.Object.Width = Adres3.Width - 4
s2.Shapes(ad1).OLEFormat.Object.Name = "Resimm " & k

If k Mod 2 = 1 Then
Else

If deg = 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + ekle
Else
sat1 = sat1 + ekle + 3
sat2 = sat1 + ekle
t = t + 1
End If
End If

Next k
Application.CutCopyMode = False
Range("A2").Select
MsgBox "işlem tamam"
End Sub

Muhammet Okumuş · 31 Mart 2020

Sn Halit cevabınız için teşekkür ederim. Verdiğiniz kodlarda resimler üst üste biniyor. Her resim arasında en az 1 satır boşluk bulunmalı. Resim sayfa altı ile sayfa başına den gelmemeli.

halit3 · 31 Mart 2020

bendeki dosyada kod çalışıyor

Muhammet Okumuş · 31 Mart 2020

Muhammet Okumuş · 31 Mart 2020

Bende bu şekil oluşturuyor.

halit3 · 31 Mart 2020

Kod ofis2003 de çalışıyor ofis2007 de çalışmadı aşağıdaki kod ofis 2007 de çalışıyor.
Bu kodu bir dene

Kod:

Private Sub CommandButton1_Click()

Set s2 = Sheets("Yerleştirme")
Set s1 = Sheets("Resim")
Set s3 = Sheets("Yerleştirme")
ReDim res1(500): ReDim res2(500)
say1 = 0
say2 = 0

Dim Picture As Object
For Each Picture In s2.Shapes
If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture

say = s2.Shapes.Count

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height > Picture.Width Then
sat = sat + 1
say1 = say1 + 1
res1(say1) = Picture.Name
End If
End If
Next Picture

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height < Picture.Width Then
sat = sat + 1
say2 = say2 + 1
res2(say2) = Picture.Name
End If
End If
Next Picture

sat1 = 1
sat2 = sat1 + 7
sut1 = 1
sut2 = 10

say3 = 0
For k = 1 To say2

Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy

say = s2.Shapes.Count
s2.Paste Destination:=s2.Range("A" & sat1)
ad1 = s2.Shapes(say).Name
'ad1 = Selection.Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,

s2.Shapes(ad1).OLEFormat.Object.Top = Adres2.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres2.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres2.Height - 4
s2.Shapes(ad1).OLEFormat.Object.Width = Adres2.Width - 4
s2.Shapes(ad1).OLEFormat.Object.Name = "Resim " & k
sat1 = sat1 + 10
sat2 = sat1 + 7
Next k

ekle = 20
sat1 = sat1
sat2 = sat1 + ekle
sut1 = 1
sut2 = 5

For k = 1 To say1

If k Mod 2 = 1 Then
sut1 = 1
sut2 = 5
Else
sut1 = 6
sut2 = 10
End If

Set Adres3 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
s1.Shapes(res1(k)).CopyPicture

say = s2.Shapes.Count
s2.Paste Destination:=s2.Range("A" & sat1)

ad1 = s2.Shapes(say).Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,
s2.Shapes(ad1).OLEFormat.Object.Top = Adres3.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres3.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres3.Height - 4
s2.Shapes(ad1).OLEFormat.Object.Width = Adres3.Width - 4
s2.Shapes(ad1).OLEFormat.Object.Name = "Resimm " & k

If k Mod 2 = 1 Then
Else
sat1 = sat1 + ekle + 3
sat2 = sat1 + ekle
End If

Next k

Application.CutCopyMode = False
Range("A1").Select
MsgBox "işlem tamam"
End Sub

Muhammet Okumuş · 31 Mart 2020

Şimdi resim aralık koyuyor. Ama sayfa sonu ile sayfa başına aynı resim denk geliyor. 54. satır sayfa sonu. 55. satır diğer sayfanın başı.

halit3 · 31 Mart 2020

Sayfaları tutturnak baya zor iş inşallah olmuştur.
Bu kodu bir dene

Kod:

Private Sub CommandButton1_Click()


Set s2 = Sheets("Yerleştirme")
Set s1 = Sheets("Resim")
ReDim res1(500): ReDim res2(500)
say1 = 0
say2 = 0

ActiveWindow.ScrollRow = 300

s2.Columns("A:A").ClearContents
say = s2.HPageBreaks.Count
'MsgBox ActiveSheet.HPageBreaks.Item(ActiveSheet.HPageBreaks.Count - 1).Location.Row + 130
sat6 = s2.HPageBreaks.Item(s2.HPageBreaks.Count).Location.Row + 65
s2.Cells(sat6, 1) = sat6
t = 1

Dim Picture As Object
For Each Picture In s2.Shapes


'MsgBox Picture.Type & Chr(10) & Picture.Name
If Picture.Type <> 12 Then
'If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
'Exit Sub
say = s2.Shapes.Count

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height > Picture.Width Then
sat = sat + 1
say1 = say1 + 1
res1(say1) = Picture.Name
End If
End If
Next Picture

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Picture.Height < Picture.Width Then
sat = sat + 1
say2 = say2 + 1
res2(say2) = Picture.Name
End If
End If
Next Picture

sat1 = 1
sat2 = sat1 + 8
sut1 = 1
sut2 = 10

say3 = 0
For k = 1 To say2


If sat1 > ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + 8
t = t + 1
End If


Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy

say = s2.Shapes.Count

s2.Paste Destination:=s2.Range("A" & sat1)

'MsgBox say
ad1 = s2.Shapes(say).Name
'ad1 = Selection.Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,

s2.Shapes(ad1).OLEFormat.Object.Top = Adres2.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres2.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres2.Height - 3
s2.Shapes(ad1).OLEFormat.Object.Width = Adres2.Width - 3
s2.Shapes(ad1).OLEFormat.Object.Name = "Resim " & k
sat1 = sat1 + 11
sat2 = sat1 + 8
Next k

ekle = 20
sat1 = sat1
sat2 = sat1 + ekle
sut1 = 1
sut2 = 5

For k = 1 To say1

If k Mod 2 = 1 Then
If sat1 > ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + ekle
End If
deg = 0

If sat2 > ActiveSheet.HPageBreaks.Item(t).Location.Row Then
If sat1 < ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat2 = ActiveSheet.HPageBreaks.Item(t).Location.Row - 3
End If
End If

sut1 = 1
sut2 = 5
Else
deg = 1
sut1 = 6
sut2 = 10
End If

Set Adres3 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))

say = s2.Shapes.Count
s1.Shapes(res1(k)).CopyPicture
s2.Paste Destination:=s2.Range("A" & sat1)

ad1 = s2.Shapes(say).Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,
s2.Shapes(ad1).OLEFormat.Object.Top = Adres3.Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Adres3.Left + 2
s2.Shapes(ad1).OLEFormat.Object.Height = Adres3.Height - 3
s2.Shapes(ad1).OLEFormat.Object.Width = Adres3.Width - 3
s2.Shapes(ad1).OLEFormat.Object.Name = "Resimm " & k

If k Mod 2 = 1 Then
Else

If deg = 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
sat2 = sat1 + ekle
Else
sat1 = sat1 + ekle + 3
sat2 = sat1 + ekle
t = t + 1
End If
End If

Next k

Cells(sat6, 1) = ""

Application.CutCopyMode = False
Range("A1").Select
MsgBox "işlem tamam"
End Sub

Muhammet Okumuş · 31 Mart 2020

Burda hata veriyor.

Muhammet Okumuş · 31 Mart 2020

Bu dosyada dar resimler için yapabiliyorum. CA:CZ sütunlarındaki formüller yerleştirme yapıyor.

halit3 · 31 Mart 2020

Sayfa ön izlemede en son A sutunundaki satıra 1 yaz ve kodu yeniden dene

Muhammet Okumuş · 31 Mart 2020

Bu da geniş resimler için.

Muhammet Okumuş · 31 Mart 2020

Şimdi hata vermedi. Çok teşekkür ederim.

halit3 · 31 Mart 2020

Kod resimler olsun olmasın son dolu satırı bulamıyor.
bu yüzden kodu çalıştırmadan önce sayfa kaydırıcı ile son hücreye gelmeli veya son hücreye select yapmalı
dosyayı her kapatıp açtığında bu olacaktır.

halit3 · 31 Mart 2020

kodun takip ettiği satıra kırmızı bölümü ekle
bu kırmızı bölüm satır 300 gösteriyor.

Rich (BB code):

Set s2 = Sheets("Yerleştirme")
Set s1 = Sheets("Resim")
ReDim res1(500): ReDim res2(500)
say1 = 0
say2 = 0

ActiveWindow.ScrollRow = 300

Resim yerleştirme

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Destek Ekibi

Uzman

Destek Ekibi

Uzman

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Uzman

Destek Ekibi

Uzman

Destek Ekibi

Destek Ekibi

Ekli dosyalar

Uzman

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Uzman

Uzman