OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Thread Tools Search this Thread Display Modes
Old 06-09-2007, 07:59
Posts: n/a
Default 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?
Reply With Quote
Old 06-09-2007, 13:31
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
Join Date: Mar 2005
Posts: 836

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
Reply With Quote
Old 06-09-2007, 14:03
Posts: n/a

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.
Reply With Quote
Old 06-09-2007, 14:19
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
Join Date: Mar 2005
Posts: 836

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
   ActivePage.Shapes.All.PositionX = 0
End Sub
Reply With Quote
Old 08-09-2007, 08:09
Posts: n/a

Thanks, I will try it and let you know what happens
Reply With Quote
Old 09-09-2007, 01:39
LeonoCoder LeonoCoder is offline
Junior Member
Join Date: Nov 2006
Posts: 10
Default Mozaico

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
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
If mycount Mod 4 = 3 Then mypcount = mypcount + 1
End If
mycount = mycount + 1
ActiveDocument.ReferencePoint = cdrTopLeft
End Sub
Reply With Quote

Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro for create boundary option nikhiscd Macros/Add-ons 14 31-10-2006 23:38
Cannot use Curveworks macros in a user witten macro??? jon46089 CurveWorks 2 02-03-2006 14:18
Create a Macro for a tool's settings? riccarcf Macros/Add-ons 7 20-11-2005 08:35
Problem with Page Numbering macro pmills Macros/Add-ons 1 07-05-2005 08:49
New macro to clip curves w.r.t. a border Gerard Hermans Macros/Add-ons 0 09-06-2003 07:50

All times are GMT -5. The time now is 13:48.

Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2023, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com