Macro to create reduced page images

I work with 98% vector images of crystal and glass with logs & text on them. Usually my files have anywhere from 5-15 pages with full size drawings of the piece and the graphics that are going to be put on them. I have been trying to create a script that would be able to be run when all of the graphics are done that would take a copy of each page and place them contents type page(s) which would have in a reduced size to be able to put 4 pages of graphics on it. I always use 8x10 page size so I have been trying to have it make as many pages as needed.

I have had no luck in any of this. Anyone know of a script available? Any ideas?

[wOxxOm]

AFAIK there is no integrated solution as a macro for Draw, but I would accomplish this task using wx_ExportJPG macro which will create a series of bitmap files for currently opened document. After that you can use Oberon Thumbnailer macro to make a thumbnail presentation sheet in CDR document if needed

The problem using that method is it takes about as long to do as just copying the pages and moving them. Thanks for the input though.

[wOxxOm]

I have an old macro that stacks all pages' contents in one column on the first page, maybe it will help.

Sub collectPages()
   Dim s As Shape, p As Page, sr As New ShapeRange, prevSh As New ShapeRange, y#
   ActiveDocument.BeginCommandGroup "collect pages"
   For Each p In ActiveDocument.Pages
      p.Activate: Set sr = p.Shapes.All: sr.RemoveRange prevSh
      Set s = sr.Group: prevSh.Add s
      s.PositionX = -s.SizeWidth * 2
      s.PositionY = y: y = y + s.SizeHeight
   Next p
   ActiveDocument.Pages(1).Activate
   ActivePage.Shapes.All.PositionX = 0
   ActiveDocument.EndCommandGroup
End Sub

Thanks, I will try it and let you know what happens

[LeonoCoder]

I had this code, I made a little modification, maybe it's similar to what you want !!!

Public Sub mozaico()
'Mozaico (4 pages in 1) by JMMisa 09/Set/2007
Dim sr As ShapeRange
Dim mypages As Integer, mywidth As Double, myheight As Double
mypages = ActiveDocument.Pages.Count
ActivePage.GetSize mywidth, myheight
Dim myp As Integer
myp = Int(mypages / 4)
If mypages / 4 <> Int(mypages / 4) Then myp = myp + 1
ActiveDocument.AddPagesEx myp, mywidth, myheight
Dim mycount As Integer, mypcount As Integer
mypcount = mypages + 1
ActiveDocument.Unit = ActiveDocument.Rulers.HUnits
Dim pp As Page
Dim mysh As Shape
For Each pp In ActiveDocument.Pages
If pp.Index <= mypages And mywidth = pp.SizeWidth And myheight = pp.SizeHeight Then
Set sr = pp.Shapes.All
sr.Duplicate
Set mysh = pp.ActiveLayer.CreateRectangle(0, myheight, mywidth, 0)
sr.Add mysh
Select Case mycount Mod 4
Case 0
ActiveDocument.ReferencePoint = cdrTopLeft
Case 1
ActiveDocument.ReferencePoint = cdrTopRight
Case 2
ActiveDocument.ReferencePoint = cdrBottomLeft
Case 3
ActiveDocument.ReferencePoint = cdrBottomRight
End Select
sr.Stretch 0.5, 0.5
sr.Cut
ActiveDocument.Pages(mypcount).ActiveLayer.Paste
If mycount Mod 4 = 3 Then mypcount = mypcount + 1
End If
mycount = mycount + 1
Next
ActiveDocument.ReferencePoint = cdrTopLeft
End Sub