• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Resim yerleştirme

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

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
 
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
 
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.

Resimlerin Boyutlarını Toplu Değiştirme

Bu uygulama exe uzantılı olup vb6 yapıldı Resimlerle ilgili uzantı değiştirmek boyut değiştirme ve küçültme işlemlerini yapmakdadır.
www.excel.web.tr www.excel.web.tr
 
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.
 
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
 
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.
 
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

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
 
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:
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.
 
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.
 

Ö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.
 
Merhaba Muhammet Hocam,
Benzer durum bende de oldu. Aynı çalışmayı yeniden hazırladım. Sorunsuz çalışıyorum.
İyi çalışmalar
 
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?
 
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
 
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.
 
Merhaba Hocam,
Bilemem, belki uzmanlar bir fikir verebilir.
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst