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 02-10-2009, 22:48
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default quick way to uncombine and make viewable?

Hi,
When you break apart an object in coreldraw it usually turns black(all the shapes inside take on a black fill)
I was wondering if there was a macro out there (somewhere) that can break apart and object and fill all of the parts inside with alternating colors.
Example. Say You wanted to convert your black and white designs to color.
If I have a lot of combined objects on the screen I could convert all to bitmap, trace and send back to draw.
The result I get I can simply ungroup and begin filling in colors.

I probably confused the ... out of yall.

Let me know if it doesn't make sense..

John
Reply With Quote
  #2  
Old 03-10-2009, 09:55
Joe Joe is offline
Member
 
Join Date: Nov 2008
Location: Latvia
Posts: 92
Send a message via Skype™ to Joe
Default Break Apart and Color

Something like... THIS?
Code:
Sub BreakApartAndColor()
    If ActiveSelection.Shapes.Count = 0 Then Beep: Exit Sub
    ActiveDocument.BeginCommandGroup "Break Apart and Color"
    
    Dim BreakMe As ShapeRange, ColorMe As Shape
    Set BreakMe = ActiveSelectionRange.Shapes.First.BreakApartEx
    
    For Each ColorMe In BreakMe.Shapes
        ColorMe.Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
    Next ColorMe
    
    ActiveDocument.EndCommandGroup
End Sub
I went for pretty colors, but you may change those values to something you prefer, of course.
Reply With Quote
  #3  
Old 03-10-2009, 12:22
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Hmm...

Cool effect but it doesn't help with the shapes inside of shapes. They are still not visible.

I think this would be a could default feature for a new coreldraw by the way.
When breaking apart a combined object it could default to alternating colors (like a default brown and yellow per say) Defaulting to a color scheme like this would let you know when you broke apart a combined item. You could easily see all shapes, instead of switching to wireframe view or fishing.

The main/largest shape will have to go to the bottom.
All shapes inside of shapes will have to be move to the top - stacked using alternating colors.
So the first bottom shape would be the largest so set it as say, dk brown.
Shapes inside of it would all be set to yellow. Any shapes inside of those would be dk brown, and son on...

I'm gonna fiddle with this.
Should be a good challenge.
Any help would be great though.....


Thanks!
John
Reply With Quote
  #4  
Old 03-10-2009, 12:28
Joe Joe is offline
Member
 
Join Date: Nov 2008
Location: Latvia
Posts: 92
Send a message via Skype™ to Joe
Default

I see what you wanted now. Well, the current result is related to the way that CorelDRAW separates the shapes. I think that finding "inner" shapes and setting them in front of the current ones is possible. Now as for nice base-shape related coloring... Well, maybe. That's a bit advanced for a quick macro.
Reply With Quote
  #5  
Old 12-10-2009, 20:54
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default well...try this

try this one.
This takes a combined shape and breaks it apart, you will be able to see every shape. Shapes ordered from largest to smallest.

It's still in the works.
I would rather it look like a black and white design (or brown and yellow --see above), but I'll have to work on that.

For now at least I got the "srFinal" shaperange sorted from the smallest shape to the largest shape.
I would love to hear comments on my methods and improvement ideas from anyone....

(some commented lines are there for testing and playin around)

Feel free to comment....

Code:
Public Sub breakApartSpecial()
    Dim i As Long, j As Long
    Dim x As Double 'width of shape
    Dim y As Double 'height of shape
    Dim a As Double 'area
    Dim Count As Long
    Dim Count2 As Integer 'i just wanna know how many shapes in final sr
    
    Dim s As Shape
    Dim sr As ShapeRange
    Dim num As Integer
    Dim var As Double
    Dim srFinal As New ShapeRange 'sorted array
    
    Dim temp As Double, temp2 As Double
    
    Dim sLowest As Double
    Dim sIdsmallest As Integer
    
    BeginCommandGroup ("smart break apart and fill")

    If ActiveSelection.Shapes.Count = 0 Then Exit Sub
    ActiveLayer.Shapes.All.BreakApart
    
    Count = ActiveLayer.Shapes.Count 'shapes in first shaperange
    
    Set sr = ActiveLayer.Shapes.All
    For i = 1 To Count 'this assigns a name property to each shape based on area (size)
        sr(i).GetSize x, y
        a = x * y
        sr(i).Name = Round(a, 10)
        'sr(i).Fill.ApplyUniformFill CreateCMYKColor(0, 0, 100, 100)
    Next i
    
    
    For j = 1 To Count
        If var = 0 Then
            temp = 1000
            sLowest = 0
            For i = 1 To Count 'find the smallest shape looping through each time
                temp2 = sr(i).Name
                If temp2 < temp Then
                    
                        sIdsmallest = i 'smallest shapes id
                        sLowest = sr(i).Name 'smallest shapes name
                        temp = sr(i).Name
                        'sr(i).CreateSelection
                    
                End If
            Next i
        Else
            temp = 1000
            sLowest = 0
            For i = 1 To Count 'find the smallest shape looping through each time
                temp2 = sr(i).Name
                If temp2 <= temp And temp2 > var Then
                    
                        sIdsmallest = i 'smallest shapes id
                        sLowest = sr(i).Name 'smallest shapes name
                        temp = sr(i).Name
                        'sr(i).CreateSelection
                    
                End If
            Next i
        End If
        
        var = sr(sIdsmallest).Name
        'sr(sIdsmallest).CreateSelection
        'sr(sIdsmallest).Outline.Width = 0.01
        srFinal.Add sr(sIdsmallest) 'assign found next size shape to final shaperange
        Count2 = srFinal.Count 'shapes in final shaperange
    Next j
    
    
    
    'num = 2
    For Each s In srFinal
        s.Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
        s.OrderToBack
        'num = num + 5
    Next s
    
        
    
   EndCommandGroup


End Sub
Reply With Quote
  #6  
Old 14-10-2009, 22:29
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default ok..here it is

Now its getting better....

Would you rather have an item you break apart in corel draw look like this.

Revised:
Fix: now selects and finds every single shape. Smallest shapes layered to the top.

1) option to "break apart special" only the selected item or all items on the page.

2) option for your "crazy colors"

after breaking apart items you can easily see all shapes and color them, or do with them what you wish.

known bugs: doesn't seem to work on extra large graphics (like over 5 feet)

still waiting on some comments, lol. Let me know if there's any function/methods that would work better. ideas...love to hear em.

Try the new code:

Code:
Public Sub breakApartSpecial()
    Dim i As Long, j As Long
    Dim x As Double 'width of shape
    Dim y As Double 'height of shape
    Dim a As Double 'area
    Dim Count As Long
    Dim Count2 As Integer 'i just wanna know how many shapes in final sr
    Dim s As Shape
    Dim sr As ShapeRange
    Dim sr1 As ShapeRange
    Dim var As Double
    Dim srFinal As New ShapeRange 'sorted array
    Dim temp As Double, temp2 As Double
    Dim sLowest As Double
    Dim sIdsmallest As Integer
    Dim message1 As String, response
    Dim message2 As String, response2
    Dim crazycolors As Integer
    
    response2 = MsgBox("Crazy Colors?", vbYesNo, "Quick question")
    If response2 = vbYes Then
        crazycolors = 5
    End If
    
    
   ActiveDocument.BeginCommandGroup ("smart break apart and fill")

    If ActiveSelection.Shapes.Count = 0 Then
        message1 = "Are you sure you want to break apart all shapes on the page"
        response = MsgBox(message1, vbOKCancel, "Message")
        If response = vbOK Then
        ActiveLayer.Shapes.All.Combine
            Set sr = ActiveLayer.Shapes.All.BreakApartEx
            Count = sr.Shapes.Count
        Else
            Exit Sub
        End If
    Else
        Set sr = ActiveSelection.Shapes.All.BreakApartEx
        Count = sr.Shapes.Count 'shapes in first shaperange
    End If
        
    For i = 1 To Count 'this assigns a name property to each shape based on area (size)
        sr(i).GetSize x, y
        a = (x * y)
        sr(i).Name = Round(a, 10) + ((Int((999 - 100 + 1) * Rnd + 100)) * 0.00000001)
    Next i
    
    
    For j = 1 To Count
        If var = 0 Then
            temp = 1000
            sLowest = 0
            For i = 1 To Count 'find the smallest shape looping through each time
                temp2 = sr(i).Name
                If temp2 < temp Then
                    sIdsmallest = i 'smallest shapes id
                    sLowest = sr(i).Name 'smallest shapes name
                    temp = sr(i).Name
                    'sr(i).CreateSelection
                End If
            Next i
        Else
            temp = 1000
            sLowest = 0
            For i = 1 To Count 'find the next smallest shape looping through each time
                temp2 = sr(i).Name
                If temp2 <= temp And temp2 > var Then
                    sr(i).Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
                    sIdsmallest = i 'smallest shapes id
                    sLowest = sr(i).Name 'smallest shapes name
                    temp = sr(i).Name
                    'sr(i).CreateSelection
                End If
             Next i
        End If
        var = sr(sIdsmallest).Name
        addedToNew = addedToNew & " A" & sIdsmallest & "A "
        srFinal.Add sr(sIdsmallest) 'assign found next size shape to final shaperange
        Count2 = srFinal.Count 'shapes in final shaperange
    Next j
    
    For i = 1 To srFinal.Count
        If crazycolors = 5 Then
            srFinal(i).Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
        Else
            srFinal(i).Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 20)
        End If
        srFinal(i).Outline.Width = 0.01
        srFinal(i).OrderToBack
    Next i
    ActiveDocument.EndCommandGroup

End Sub

have a goodin'

-John
Reply With Quote
  #7  
Old 16-10-2009, 00:33
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,788
Blog Entries: 12
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default My attempt

Sorry I have not had much time so here is my quick attempt. Basically it puts the ShapeRange into a Two Dimensional Array and sorts the Array, then from the sorted Array is build a new ShapeRange.

As I said, not a lot of time with the code, so there could be issues. If anything it gives you an example of another way to do it.

Code:
Sub SmartBreakApart()
    Dim s As Shape, i As Long
    Dim srBroken As New ShapeRange
    Dim srSelection As ShapeRange
    
    If ActiveSelection.Shapes.Count = 0 Then MsgBox "Please make a selection.": Exit Sub 'Check if something is selected
    
    Set srSelection = ActiveSelectionRange 'Get the selection
    Set srSelection = srSelection.Group.UngroupAllEx 'Remove any Groups in Selection
    
    'Breakapart any curved shapes while maintaining other shapes such as a rectangle
    For Each s In srSelection
        If s.Type = cdrCurveShape Then
            If s.Curve.SubPaths.Count > 1 Then
                srBroken.AddRange s.BreakApartEx 'Add the new broken pieces of the curve
            Else
                srBroken.Add s 'If a single curve add it to shaperange
            End If
        Else
            srBroken.Add s 'If any shape other than curve add to shaperange
        End If
    Next s
    
    Set srBroken = OrderBySize(srBroken) 'Get the sorted shaperange (Largest to Smallest)
   
    For i = 1 To srBroken.Count
        srBroken(i).OrderToFront 'Move shape to front
        srBroken(i).Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
    Next i
End Sub

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
Best of luck,

-Shelby
Reply With Quote
  #8  
Old 16-10-2009, 12:03
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

This means war!

No, just kidding Shelby. TGIF.

Your seems to work faster than mine.
Works good too. You can see your experience in the code.
I'm gonna learn from your code too.

I just added a commandgroup to it, and outlined the shapes.

I got a great idea to completely redo this whole idea.
I'm gonna start working on it.
I'm hoping it will be a very simple way to do this and hopefully make it black and white (or brown and yellow -as described above)...or a choice of 2 colors...

I've only been playing with the vba for around 2 weeks now so I hope I can do it. I'll post it here soon.

-John
Reply With Quote
  #9  
Old 16-10-2009, 13:16
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,788
Blog Entries: 12
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Two Colors

I originally had it doing only two colors, the problem then comes in when you have multiple shapes the same size, those that are one on top of the other may not be colored in the alternate colors. If that makes sense.

Ideally you would want the shape to to look at the shape underneath it and alternate the color. However there is no built in method for this, so it would take a bit of coding and I simply ran out of time.

If you want to try my 2 color method. Change this line:
Code:
srBroken(i).Fill.ApplyUniformFill CreateHLSColor(Rnd * 360, 128, 255)
To this:
Code:
If IsOdd(i) Then
     srBroken(i).Fill.ApplyUniformFill CreateCMYKColor(0, 20, 40, 40)
Else
     srBroken(i).Fill.ApplyUniformFill CreateCMYKColor(0, 0, 100, 0)
End If
You will also need this little function to test if the number is odd.
Code:
Private Function IsOdd(i As Long) As Boolean
    IsOdd = (i Mod 2) <> 0
End Function
Hope that helps,

-Shelby

Last edited by shelbym; 16-10-2009 at 13:22.
Reply With Quote
  #10  
Old 16-10-2009, 13:29
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi,
Sure. Thanks!
I'll check it out.

My new plan was to use a loop and the GetUserArea (i think thats the function) that creates a marquee selector that passes through the object like a scanner.

The marquee select would continually change size and get smaller.

It would make as many passes as shape layers.
It would have to alternate colors with passes, or complete passes.

I'm not sure it this would work , but I was gonna try.


-John
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
Custom workspace not viewable gbyoon General 5 27-11-2006 00:08
Custom workspace not viewable gbyoon CorelDRAW/Corel DESIGNER VBA 0 10-06-2006 06:09
uncombine met CorelDRAW/Corel DESIGNER VBA 4 12-12-2005 22:50
Quick Switcher ddonnahoe CorelDRAW/Corel DESIGNER VBA 3 24-08-2005 14:44
quick export in vc++ andrej CorelDRAW/Corel DESIGNER VBA 2 11-07-2003 05:05


All times are GMT -5. The time now is 22:04.


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