A macro to replace PowerClip content with low-res preview and back.

Helo, all!

I have been spending a good amount of time looking into ways of improving CorelDRAW's performance. Especially with more complex objects, higher amounts of shapes, etc.

Having looked into things and not finding a decent way to speed things up I decided to have a different approach - temporarily making things simpler so CorelDRAW has an easier time. The result is a system that can replace PowerClip content (for now) with a low-res preview and back as necessary. Here is a short video explaining it (sorry for my English, I am not a native speaker):

https://vimeo.com/494941706

And here is the code. I am certain the code ninjas here will have at least some ideas on how to make this more efficient:

'TempIT v0.06
'Externally link Anything inside a PowerClip

Sub TempITSave()
    On Error GoTo ErrorOccured
    If ActiveDocument Is Nothing Then
        MsgBox "Please have a Document open!", vbOKOnly Or vbExclamation, "TempIT!"
        Exit Sub
    End If
    
    If ActiveSelectionRange.Shapes.Count = 0 Then
        MsgBox "Please have at least one Selected Shape!", vbOKOnly Or vbExclamation, "TempIT!"
        Exit Sub
    End If
    
    If ActiveDocument.FileName = "" Then
        MsgBox "Current Document has Not been saved. Using temporary Shape replacement impossible." & vbCrLf & "" & vbCrLf & "Quitting Macro.", 48, "TempIT!"
        Exit Sub
    End If
    
    'Speed things up and remove all that flashing etc
    Optimize True
    
    Dim TestShape As Shape, TempShape As Shape
    Dim TestRange As ShapeRange
    Dim TempPath As String
    Dim DocOps As New StructSaveAsOptions
    
    'Temporary Shapes will be saved here
    TempPath = ActiveDocument.FilePath & "TempIT\"
    
    'If we haven't used this Path yet then create it
    If Dir(TempPath, vbDirectory) = "" Then
        MkDir TempPath
    End If
    
    'Let's loop through Shapes
    For Each TestShape In ActiveSelection.Shapes.All
        'Currently only works with PowerClip Contents
        If Not TestShape.PowerClip Is Nothing Then
            'Is there anything inside the shape
            If TestShape.PowerClip.Shapes.Count <> 0 Then
                'Let's grab those Shapes and save them as a Temporary File
                Set TestRange = TestShape.PowerClip.Shapes.All
                TestShape.PowerClip.ExtractShapes
                
                DocOps.EmbedICCProfile = False
                DocOps.EmbedVBAProject = False
                DocOps.IncludeCMXData = False
                DocOps.Filter = cdrCDR
                DocOps.Overwrite = True
                DocOps.Range = cdrSelection
                DocOps.Version = cdrCurrentVersion
                
                TestRange.CreateSelection
                ActiveDocument.SaveAs TempPath & TestShape.StaticID & ".cdr", DocOps
                
                'Now let's convert those Shapes into a Bitmap...
                Set TempShape = TestRange.ConvertToBitmap(24, False, True, True, 25, cdrNormalAntiAliasing)
                '...tag it for later retrieval...
                TempShape.Properties("TempIT", 0) = TestShape.StaticID
                    'TempShape.Properties("TempIT", 1) = TestShape.RotationAngle
                '...and add that Bitmap to Parent Shape's Powerclip
                TempShape.AddToPowerClip TestShape
            End If
        End If
    Next TestShape
Success:
    'Alright!
    Optimize False
    Exit Sub
ErrorOccured:
    'Oh no!
    MsgBox "A critical Error occurred: " & vbCrLf & Err.Description, 16, "Critical error!"
    Err.Clear
    Resume Success
End Sub

Sub TempITLoad()
    On Error GoTo ErrorOccured
    If ActiveDocument Is Nothing Then
        MsgBox "Please have a Document open!", vbOKOnly Or vbExclamation, "TempIT!"
        Exit Sub
    End If
    
    If ActiveSelectionRange.Shapes.Count = 0 Then
        MsgBox "Please have at least one Selected Shape!", vbOKOnly Or vbExclamation, "TempIT!"
        Exit Sub
    End If
    
    If ActiveDocument.FileName = "" Then
        MsgBox "Current Document has Not been saved. Using temporary Shape replacement impossible." & vbCrLf & "" & vbCrLf & "Quitting Macro.", 48, "TempIT!"
        Exit Sub
    End If
    
    Dim TestShape As Shape, TempShape As Shape, TempRange As ShapeRange
    Dim TempPath As String
    Dim DocOps As New StructSaveAsOptions
    Dim PreviousRotation As Double
    
    TempPath = ActiveDocument.FilePath & "TempIT\"
    
    'Do we even have any Shapes to replace in the Temp Folder?
    If Dir(TempPath, vbDirectory) = "" Then
        MsgBox "No Replaced Shapes available!", vbOKOnly Or vbExclamation, "TempIT!"
        Exit Sub
    End If
    
    'Optimize True
    
    'Let's go through shapes
    For Each TestShape In ActiveSelection.Shapes.All
        If Not TestShape.PowerClip Is Nothing Then
            For Each TempShape In TestShape.PowerClip.Shapes
                'Is a Replaced Shape present
                If TempShape.Properties.Exists("TempIT", 0) Then
                    'Is its Original available
                    If Dir(TempPath & TempShape.Properties("TempIT", 0) & ".cdr") <> "" Then
                        'Slightly clumsy Shape import and assign to a ShapeRange
                         ActiveLayer.Import TempPath & TempShape.Properties("TempIT", 0) & ".cdr"
                        'I could not find a way to do this directly
                        Set TempRange = ActiveSelectionRange
                        'Add to PowerClip and set same Size and Location as the Temp Shape
                        TempRange.AddToPowerClip TestShape
                        
                        'Should we rotate the shape so the content looks correct?
                        
                        'THIS DOES NOT REALLY WORK THE MOMENT ANGLES ARE NON MOD 90
                        'THE BITMAP IS WAY BIGGER AT AN ANGLE AND PRECISION IS DESTROYED
                        
                        'If TempShape.Properties.Exists("TempIT", 1) Then
                            'PreviousRotation = TempShape.RotationAngle
                            'TempShape.Rotate (360 - TempShape.RotationAngle)
                            'TempRange.SetSize TempShape.SizeWidth
                            'TempShape.Rotate PreviousRotation
                        
                            'TempRange.Rotate (TempShape.RotationAngle + TempShape.Properties("TempIT", 1)) Mod 360
                        'End If
                        
                        TempRange.CenterX = TempShape.CenterX
                        TempRange.CenterY = TempShape.CenterY
                        
                        'Remove the Temp Shape
                        TempShape.Delete
                    End If
                End If
            Next TempShape
        End If
    Next TestShape
Success:
    'Optimize False
    Exit Sub
ErrorOccured:
    MsgBox "A critical Error occurred: " & vbCrLf & Err.Description, 16, "Critical error!"
    Err.Clear
    Resume Success
End Sub

'=-=-=-=-=-=-=-=
' OPTIMIZE STUFF
'=-=-=-=-=-=-=-=

Private Sub Optimize(Use As Boolean)
    If Use Then
        'Thanks for the cursor, Shelby!
        CorelScriptTools.BeginWaitCursor
        ActiveDocument.BeginCommandGroup ""
        Optimization = True
        EventsEnabled = False
        ActiveDocument.SaveSettings
    Else
        ActiveDocument.RestoreSettings
        Optimization = False
        EventsEnabled = True
        ActiveDocument.EndCommandGroup
        ActiveWindow.Refresh
    End If
End Sub

Updates:
Decided that I will put any updated code right back here and have a changelog:

0.04 Removed an unnecessary debug line of code: TempShape.ApplyEffectHSL 50, 0, 0
0.06 Attempted to add a rotation feature, but given that the bitmaps are rectangles and their centers behave differently the results get shifted. A fix could be saving their center and then using math to do this properly, but that is beyond my skill levels.

Parents
  • With the holiday I have played with my grandchildren more than CorelDRAW , with that said on my system there is a speed increase by converting the many powerclipped objects to an image, however it can be done at a resolution suitable for output not just for preview. I'll play with this more in days to come.

Reply Children