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 08-02-2007, 06:21
keytecstaff
Guest
 
Posts: n/a
Question Scale with Image

Hi,

We have a macro which will search all of the shapes in a CorelDraw document and make sure the Scale With Image option is set to True.

If we get a document which has lots of shapes for example over 10,000 this macro takes a long time to complete. See below for macro:

Code:
Sub scaling_on()
    ActivePage.Shapes.All.CreateSelection
    ApplyScaleWithShape ActiveSelection.Shapes
End Sub


Private Sub ApplyScaleWithShape(ss As Shapes)
    Dim s As Shape
  
    For Each s In ss
        Select Case s.Type
            Case cdrCurveShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrTextShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrMeshFillShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrPolygonShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrLinearDimensionShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrConnectorShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrEllipseShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrRectangleShape
                If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                    s.Outline.ScaleWithShape = True
                End If
            Case cdrGroupShape
                ApplyScaleWithShape s.Shapes
        End Select
    Next s
End Sub
Does anyone know of anyway this macro can be optimised to speed the process up?

My PC specs are:
AMD sempron 3100+
1GB RAM
Radeon 9250 graphics with 128MB
40GB SATA Hard drive with 30GB free.
Running Windows XP Home SP2
CorelDraw X3 with SP2

The reason why I ask this is when I import PDF files the objects always come in with the Scale With Image off, if anyone knows a way to make it default to on when I import PDF files that will be great. Also when I import a PDF and ungroup all then select all and turn the Scale With Image on by hand it is much faster than running the macro.

Many thanks,

Kevin
Reply With Quote
  #2  
Old 08-02-2007, 09:01
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

try this one, should run fast - http://recentfiles.sbn.bz/misc/wx_outlineNONScaled.exe
macros are OutlinesScaledON and OutlinesScaledOFF

the trick is in disabling autorefresh of screen:
Code:
Public Sub boostStart(Optional ByVal unDo$ = "")
   Optimization = True
   EventsEnabled = False
   ActiveDocument.SaveSettings
   ActiveDocument.PreserveSelection = False
   End Sub

Public Sub boostFinish()
   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   Application.CorelScript.RedrawScreen
   End Sub
Reply With Quote
  #3  
Old 08-02-2007, 09:37
keytecstaff
Guest
 
Posts: n/a
Talking

Hi wOxxOm,

Wow that is much faster thanks very much. It just performed the operation in just a second and before it was taking over 5 mins.

You say that disabling autorefresh of screen does the trick but we already have that setup as a sub routine which is called before the "scaling_on" macro we have written. The only difference between ours and yours is that I noticed you have a line saying "ActiveDocument.PreserveSelection = False" which we don't.

Thanks for the help.

Kevin.
Reply With Quote
  #4  
Old 08-02-2007, 13:55
Malik641
Guest
 
Posts: n/a
Default

Hey Kevin,

Your main code can be shortened significantly like this (for future refence on the Select Case usage):
Code:
Private Sub ApplyScaleWithShape(ss As Shapes)
    Dim s As Shape
    
    For Each s In ss
        Select Case s.Type
            Case cdrCurveShape, cdrTextShape, cdrMeshFillShape, _
                cdrPolygonShape, cdrLinearDimensionShape, cdrConnectorShape, _
                cdrEllipseShape, cdrRectangleShape
                    If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                        s.Outline.ScaleWithShape = True
                    End If
            
            Case cdrGroupShape
                ApplyScaleWithShape s.Shapes
        End Select
    Next s
End Sub
Reply With Quote
  #5  
Old 12-02-2007, 10:01
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Quote:
Originally Posted by wOxxOm
Application.CorelScript.RedrawScreen
Nah, using CorelScript. I would replace this with a nicer native command like this:

Code:
Application.Refresh
In order to speed things up a bit more, I would build a ShapeRange of all the objects you want to apply the outline to and then do this in one step:

Code:
Private Sub ApplyScaleWithShape(ByVal ss As Shapes)
    Dim s As Shape
    Dim sr As New ShapeRange
    
    For Each s In ss
        If s.Type = cdrGroupShape Then
            ApplyScaleWithShape s.Shapes
        ElseIf s.CanHaveOutline Then
            If s.Outline.Type = cdrOutline And Not s.Outline.ScaleWithShape Then
                sr.Add s
            End If
        End If

        If sr.Count > 0 Then sr.SetOutlineProperties ScaleWithShape:=cdrTrue
    Next s
End Sub

Last edited by Alex; 12-02-2007 at 10:10.
Reply With Quote
  #6  
Old 12-02-2007, 10:13
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

ho! built-in app.refresh doesn't redraw object handles and statusbar info with number of objs selected etc. This bug is built-in since well v12 I think. corelscript is the only way out
Reply With Quote
  #7  
Old 12-02-2007, 10:14
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Well, this needs to be logged as a bug then. I'll forward the info.
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
Display Current Scale Drumart Macros/Add-ons 1 06-07-2006 07:06
Image picture location RVogel CorelDRAW/Corel DESIGNER VBA 0 31-03-2005 12:05
Apply Outline - Scale with Image geopig CorelDRAW/Corel DESIGNER VBA 4 06-05-2004 07:23
Population of Image Box ddonnahoe CorelDRAW/Corel DESIGNER VBA 10 10-02-2004 13:20
Import image into bounding box Craig Tucker CorelDRAW/Corel DESIGNER VBA 2 07-10-2003 20:06


All times are GMT -5. The time now is 20:37.


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