Resim yerleştirme

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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

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

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

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod birazcık farklı bunu bir dene
kod ofis 2007 ve üzeri çalışır.

Not: Kod hata verirse bir daha 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

son_sat = 300
s2.Range("A" & son_sat & ":J" & son_sat).Borders(xlEdgeBottom).LineStyle = xlContinuous

ActiveWindow.ScrollRow = son_sat

t = 1

Dim Picture As Object
For Each Picture In s2.Shapes
'MsgBox Picture.Type & Chr(10) & Picture.Name
If Picture.Type <> 12 And Picture.Type <> 8 Then
'If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
'Exit Sub
say6 = s2.Shapes.Count
'Exit Sub
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))

say = s2.Shapes.Count - say6 + 1

s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy

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 = 19
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 - say6 + 1

s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy

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

Application.CutCopyMode = False

s2.Range("A" & son_sat & ":J" & son_sat).Borders(xlEdgeBottom).LineStyle = xlNone


Range("A2").Select
MsgBox "işlem tamam"
End Sub
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Sn Halit Bey,
Resimler aynı renk olunca fark edememişim ama kod resimleri orantısız büyütüp/küçülttüğü için sorular bozuluyor. Soru genişlikleri eşit olabilir ama yükseklikler eşit olmamalı. Sorular üzerinde deneyince fark ettim. 215926
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodlar yazılınca örnek dosyanızdaki resimlere göre yazıldı dolayısıyla sayfalara sığdırmak için resimler küçülüp büyümektedir.
BU resimler harici bir klasörde ise farklı bir yazılımla resimlerin ölçeklendirilmesinin hepsinin aynı yapılması daha sağlıklı olacağına inanıyorum.

Resimlerin boyutlarını aşağıdaki linkdeki dosya ile yapabilirsiniz.

 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Toplu degistorme yerine resmi yerleştirirken en&boy oranı kilitli olunca resimde bozulma olmuyor. Ben gönderdiğim Test oluşturma dosyası resim al makrosunda tüm resimlerin genişliklerini aynı yapıyor. En boy oranı kilitli olduğundan yükseklikler farklı oluyor. Yine de çok teşekkür ederim. Sizi uğraştırdım. Resimlerin hepsi dar veya geniş olunca yapıyorum ama bir türlü karma olan resimlerin dizgisini yapamadim.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu son olarak yazdım bir dene belki işe yarar

Kod:
Private Sub CommandButton1_Click()


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

son_sat = 600
s2.Range("A" & son_sat & ":J" & son_sat).Borders(xlEdgeBottom).LineStyle = xlContinuous

ActiveWindow.ScrollRow = son_sat


Cells(son_sat, 1) = 1
t = 1

Dim Picture As Object
For Each Picture In s2.Shapes
'MsgBox Picture.Type & Chr(10) & Picture.Name
If Picture.Type <> 12 And Picture.Type <> 8 Then
'If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
'Exit Sub
say6 = s2.Shapes.Count
'Exit Sub
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


Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
Adres3 = s2.Cells(sat1, sut1).Address
say = s2.Shapes.Count - say6 + 1
s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy
s2.Paste Destination:=s2.Range("A" & sat1)
ad1 = s2.Shapes(say).Name
sayy1 = s2.Shapes(ad1).BottomRightCell.Row
Range("m" & sayy1).Select
sayy2 = s2.Shapes(ad1).TopLeftCell.Row
sat1 = sayy1 + 3
deg1 = 0

If sayy1 > ActiveSheet.HPageBreaks.Item(t).Location.Row - 1 Then
sat1 = ActiveSheet.HPageBreaks.Item(t).Location.Row
Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
Adres3 = s2.Cells(sat1, sut1).Address
t = t + 1
deg1 = 1
End If
'ad1 = Selection.Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse ' msoCTrue,
s2.Shapes(ad1).OLEFormat.Object.Top = Range(Adres3).Top + 2
s2.Shapes(ad1).OLEFormat.Object.Left = Range(Adres3).Left + 2
s2.Shapes(ad1).OLEFormat.Object.Width = Adres2.Width - 3

If deg1 = 1 Then
sat1 = s2.Shapes(ad1).BottomRightCell.Row + 3
End If
s2.Shapes(ad1).OLEFormat.Object.Name = "Resim " & k

Next k

ekle = 19
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 - say6 + 1

s1.Shapes(res2(k)).CopyPicture
's1.Shapes(res2(k)).Copy

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
sayy1 = s2.Shapes(ad1).BottomRightCell.Row
'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
sat1 = sayy1 + 3

sat2 = sat1 + ekle
t = t + 1
End If
End If

Next k

Application.CutCopyMode = False

s2.Range("A" & son_sat & ":J" & son_sat).Borders(xlEdgeBottom).LineStyle = xlNone


Range("A2").Select
MsgBox "işlem tamam"
End Sub
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Sn Halit sizi uğraştırmaktan kendi adıma rahatsız olmaya başladım. Resimler düzeldi ama bu kez de üst üste bindirme yapıyor. Olmazsa ben manuel olarak kopyala yapıştır yapayım. W ile Q tuşları resmi yerleştiriyor.
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Uzun uğraşlardan sonra başardım. Abartmıyorum en az 8 saat uğraştım. İlgilenen tüm arkadaşlara çok teşekkür ederim.

 

Ekli dosyalar

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,593
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba Muhammet Hocam,
Hem sizin, hem Halit3 hocanın ellerinize ve emeğinize sağlık. Sınav hazırlığında ne yapıyorsunuz? Soruları çeşitli kitaplardan kes yapıştır yöntemiyle almışsınız galiba. Sadece baskı yapıldığını gördüm. Doğru mu, bilmiyorum ama?
Saygılarımla
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Z-Kitaplardaki soruları tek tek (sormak istediğim) FastStone Capture (kesinlikle tavsiye ederim) ile ekran görüntüsü olarak alıp klasöre kopyalıyorum.
Daha önceleri soru numaraları ve resimleri tek tek kendim yapıştırıyordum. Sonradan makroların yerleştirdiği dosyayı oluşturdum ve işimi inanılmaz derecede kolaylaştırdı. Hepsi dar ve hepsi geniş olanlarda sorun yaşamıyordum. Bir türlü bu karma tipini hazırlayamamıştım. Dosyada şimdilik hataya rastlamadım. Ya da oluşan hataları düzelttim diyeyim.

Dosyadaki resimler bir çoğunda sayfaya oturmayacaktır. Taslak sayfasını kendi yazıcınıza göre ayarlarsanız ve kodlarda gerekli düzenlemeyi yaparsanız sorun çözülür. Bendeki sayfa Adobe PDF yazıcısına göre ayarlı.

Dosyadaki resimler klasörde kayıtlı.
 
Son düzenleme:

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,593
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba Muhammed Hocam,
Çok güzel, elinize sağlık. Emekli olduktan sonra soru hazırlamayı bıraktım, genel toplu sınavlar ve rehber öğretmenlerin ihtiyacı olan konularla ilgileniyorum. Bu da oldukça işe yarıyor.Çalışmalarım arasında ilginizi çeken konu olursa yardımcı olmaya çalışırım.
İlginize teşekkür eder, başarılarınızın devamını dilerim.
Saygılarımla
Bağlantıyı kaldırın isterseniz, dosyalarınız zarar görmesin.
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Memnun oldum hocam. Ben de yolun ortasındayım sayılır. Soru hazırlamak gerçekten zor. Özellikle benim branşımda görsellik oldukça önemli.
Saygılar bizden hocam. Size de iyi çalışmalar.
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe

Önceden resimleri istediğim yere yerleştiren dosya şimdi resimleri kaydırarak yerleştiriyor. Dosyada hiçbir değişiklik yapmadım. Dosyadan aldığım resimleri kendi çalışma sayfasında hep kaydırarak yerleştiriyor ama aynı resmi başka çalışma kitabına yapıştırdığımda kayma olmuyor. Daha önce yaptığım tüm dosyalarda aynı sorun var.
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,593
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba Muhammet Hocam,
Benzer durum bende de oldu. Aynı çalışmayı yeniden hazırladım. Sorunsuz çalışıyorum.
İyi çalışmalar
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Kodlarda hiçbir sorun yok. Boş bir sayfadan hücre biçimini, yapıştırma alanına uyguladığımda sorun düzeliyor. Ama bu kez de sayfa tasarımı yapmak gerekiyor. Neden böyle oldu acaba?
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,593
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba,
Benim bir defa başıma geldi. Aynı çalışmayı, üşenmeden tekrarladım. Kopyasını da emin bir yerde bıraktım. O oldu, bir daha o dosyada sıkıntı yaşamadım.
İyi çalışmalar
 

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,968
Excel Vers. ve Dili
2013 Türkçe
Tevfik Bey, anlamadığım nokta orası. Bütün dosyalarda kayma yapıyor. Buraya yüklediğim dosyayı indirdim, onda da kayma yaptı. Acaba excelde bir eklenti mi buna neden oluyor? Çok anormal bir durum.
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,593
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba Hocam,
Bilemem, belki uzmanlar bir fikir verebilir.
İyi çalışmalar
 
Üst