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:

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

[wOxxOm]

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:

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

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.

Hey Kevin,

Your main code can be shortened significantly like this (for future refence on the Select Case usage):

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

[Alex]

Originally Posted by wOxxOm

Application.CorelScript.RedrawScreen

Nah, using CorelScript. I would replace this with a nicer native command like this:

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:

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

[wOxxOm]

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

[Alex]

Well, this needs to be logged as a bug then. I'll forward the info.