- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,844
- 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
-
98.3 KB Görüntüleme: 5