OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 06-09-2007, 07:59
gingem
Guest
 
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
  #2  
Old 06-09-2007, 13:31
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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
  #3  
Old 06-09-2007, 14:03
gingem
Guest
 
Posts: n/a
Default

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

I have an old macro that stacks all pages' contents in one column on the first page, maybe it will help.
Code:
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
Reply With Quote
  #5  
Old 08-09-2007, 08:09
gingem
Guest
 
Posts: n/a
Default

Thanks, I will try it and let you know what happens
Reply With Quote
  #6  
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
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
Reply With Quote
Reply


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


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