GDG Code Chunks, Discussion, VBA Snippets for CorelDRAW, Simple Macro Helpers!

cool vba macros for corel show cart gdg corel draw macros checkout corel macros
VBA Corel Macro Help
john's macros
thanks for stopping by gdg macros















Helpful VBA Code

Please order a commercial macro ONLY if you have at least intermediate professional experience with CorelDraw and macros, no beginners PLEASE. Try FREE macros here and see my help pages to learn. Clients agree to all terms and conditions here when buying a commercial macro and using the available free macros. No refunds, no exchanges.
Note: Macros do not function in the Home & Student Edition or Pirated Versions of CorelDraw!
X7 macros do not work in CorelDraw 2017
X8 macros do not work in CorelDraw 2018
Many CorelDraw 2019 macros are here!

Join ME on Facebook to stay up to date with news, updates. Subscribe to my YouTube Channel for tutorial videos and tips. Need a custom macro? Contact me.
WINDOWS OS ONLY! Not all macros are guaranteed to be continued due to compatibility reasons or other. See new version policy here. Contact me and let me know which macro you need for the NEW CorelDraw 2019. All macros without requests could be discontinued.
I appreciate everyone! Upgrading macros and maintaining this site is quite a task. Want to contribute? Please DONATE
^ Hide these messages to save screen space ^

<<Back to helpful code list

Smart Break apart shape

Decription: This is a very handy break apart macro that took me a while to figure out. It will break apart a shape, or make a broken apart shape have alternating fill colors based on stacking order of shapes. Basically making it look as if it was a combined shape. A very handy macro that works correctly with 99% of shapes selected.

Date: 2010-09-02 Author: John Johnson

Code:
Option Explicit

Sub smartBreakApart()

Dim s As Shape, sr As ShapeRange, shs As Shape
Dim sr2 As New ShapeRange, sr3 As ShapeRange
Dim x As Double, y As Double
Dim nodecount As Long, tempDis As Double

   On Error GoTo smartBreakApart_Error

If ActiveSelection.Shapes.count = 0 Then Exit Sub

Optimization = True
EventsEnabled = False
ActiveDocument.BeginCommandGroup "smart break"

ActiveSelection.UngroupAll
Set sr2 = ActiveSelection.BreakApartEx
Set sr = OrderBySize(sr2)

tempDis = 0.005

For Each s In sr
    s.OrderToFront
    s.Fill.ApplyUniformFill CreateRGBColor(64, 32, 32)
    nodecount = 1
    s.Curve.Nodes(nodecount).GetPosition x, y
    
If 1 = 2 Then
1001:
    If nodecount <= s.Curve.Nodes.count Then
        s.Curve.Nodes(nodecount).GetPosition x, y
    Else
        GoTo 1002:
    End If
End If
    
    If s.IsOnShape(x + tempDis, y) = cdrInsideShape And s.IsOnShape(x + tempDis, y) <> cdrOnMarginOfShape Then
        x = x + tempDis
        
    ElseIf s.IsOnShape(x - tempDis, y) = cdrInsideShape And s.IsOnShape(x - tempDis, y) <> cdrOnMarginOfShape Then
        x = x - tempDis
        
    ElseIf s.IsOnShape(x, y + tempDis) = cdrInsideShape And s.IsOnShape(x, y + tempDis) <> cdrOnMarginOfShape Then
        y = y + tempDis
        
    ElseIf s.IsOnShape(x, y - tempDis) = cdrInsideShape And s.IsOnShape(x, y - tempDis) <> cdrOnMarginOfShape Then
        y = y - tempDis
        
    ElseIf s.IsOnShape(x - tempDis, y - tempDis) = cdrInsideShape And s.IsOnShape(x - tempDis, y - tempDis) <> cdrOnMarginOfShape Then
        y = y - tempDis: x = x - tempDis

    ElseIf s.IsOnShape(x + tempDis, y + tempDis) = cdrInsideShape And s.IsOnShape(x + tempDis, y + tempDis) <> cdrOnMarginOfShape Then
        y = y + tempDis: x = x + tempDis
        
    ElseIf s.IsOnShape(x - tempDis, y + tempDis) = cdrInsideShape And s.IsOnShape(x - tempDis, y + tempDis) <> cdrInsideShape Then
        y = y + tempDis: x = x - tempDis
        
    ElseIf s.IsOnShape(x + tempDis, y - tempDis) = cdrInsideShape And s.IsOnShape(x + tempDis, y - tempDis) <> cdrOnMarginOfShape Then
        y = y - tempDis:  x = x + tempDis
        
    Else
        nodecount = nodecount + 1
        's.Fill.ApplyUniformFill CreateRGBColor(255, 0, 0) 'RED - testing
        GoTo 1001:
    End If
1002:
    Set shs = ActivePage.SelectShapesAtPoint(x, y, False, tempDis / 2) 'notice!!! tempdis /2
    If Not IsOdd(shs.Shapes.count) Then s.Fill.ApplyUniformFill CreateRGBColor(255, 255, 121)
    sr2.Add s
Next s

ActiveDocument.EndCommandGroup
Optimization = False
EventsEnabled = True
ActiveWindow.Refresh

   On Error GoTo 0
   Exit Sub

smartBreakApart_Error:
    ActiveDocument.EndCommandGroup
    Optimization = False
    EventsEnabled = True
    ActiveWindow.Refresh
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure smartBreakApart of Module newSmartBreakApart"
    
End Sub

Private Function IsOdd(i As Long) As Boolean
    IsOdd = (i Mod 2) <> 0
End Function

Private Function OrderBySize(sr As ShapeRange) As ShapeRange
    Dim srSorted As New ShapeRange
    Dim s As Shape, i As Integer
    Dim t As Variant, j As Integer, y As Integer
    Dim iUpper As Integer, Condition1 As Boolean
    ReDim ShapesAndSizes(sr.count - 1, 1) As Double 'Create an Array to hold area and staticID
    
    'Add shape data to array
    For i = 1 To sr.count
        ShapesAndSizes(i - 1, 0) = Round(sr(i).SizeWidth * sr(i).SizeHeight, 3) 'Area of the shape
        ShapesAndSizes(i - 1, 1) = sr(i).StaticID 'Static ID of current shape
    Next i
    
    'A very simple sort
    For i = LBound(ShapesAndSizes, 1) To UBound(ShapesAndSizes, 1) - 1
        For j = LBound(ShapesAndSizes, 1) To UBound(ShapesAndSizes, 1) - 1
            Condition1 = ShapesAndSizes(j, 0) <= ShapesAndSizes(j + 1, 0)
            If Condition1 Then
                For y = LBound(ShapesAndSizes, 2) To UBound(ShapesAndSizes, 2)
                    t = ShapesAndSizes(j, y)
                    ShapesAndSizes(j, y) = ShapesAndSizes(j + 1, y)
                    ShapesAndSizes(j + 1, y) = t
                Next y
            End If
        Next
    Next
    
    'Create a ShapeRange from the sorted array
    For i = 0 To sr.count - 1
        srSorted.Add ActivePage.FindShape(StaticID:=ShapesAndSizes(i, 1))
    Next i

    Set OrderBySize = srSorted 'Return the new sorted shaperange
End Function




corel macros boost workflow
*Searches the FREE and Commercial Macros


CorelDraw macros for version 2019

CorelDraw macros for version 2018

CorelDraw macros for version 2017

macros for coreldraw x8

macros for coreldraw x7

macros for corel draw x6

macros for corel draw x6

FIND IT ON

find it on yahoo

FIND IT ON

find it on google