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 25-11-2011, 05:40
DecalPrint
Guest
 
Posts: n/a
Default Need help for VBA syntax

Hi there,
I need the right VBA Syntax for following problem:
Ceck if an object with any colour in the inner area from a object with CMYK 0,0,0,30

or

check if an object with any colour lays over a object with CMYK 0,0,0,30

All other objects with any colour outside from objects with CMYK 0,0,0,30 must be deleted.

This is a part of an colour-layer separation macro, who can split the colours for Roland printers. The trick to make "invisible" all objects on the spot colour layer with CMYK 0,0,0,0 or 0% Spot Colour doesnt works. The printout have massive errors.

I hope anyone can help me.
Kind regards
Reply With Quote
  #2  
Old 27-11-2011, 13:17
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
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 Overlap Syntax Help

This is a modified version of some code by Alex found here: A Shape on Top of Another please check that thread for full details. I have modified the code to work with CMYK 0, 0, 0, 30 as you asked and it should do the trick.

Code:
Sub RemoveCMYK00030Objects()
    Dim sr As ShapeRange
    Dim i As Long, j As Long
    Dim s1 As Shape, s2 As Shape
    Dim bOverlap As Boolean
    Dim nDelCount As Long
    
    Set sr = ActivePage.FindShapes()
    
    nDelCount = 0
    For i = 1 To sr.Count - 1
        Set s1 = sr(i)
        If ValidTopObject(s1) Then
            bOverlap = False
            For j = i + 1 To sr.Count
                Set s2 = sr(j)
                If ValidBottomObject(s2) Then
                    If Overlap(s1, s2) Then
                        bOverlap = True
                        Exit For
                    End If
                End If
            Next j
            
            If Not bOverlap Then
                s1.Delete
                nDelCount = nDelCount + 1
            End If
        End If
    Next i
    
    MsgBox nDelCount & " CMYK(0, 0, 0 ,30) object(s) deleted", vbInformation
End Sub

Private Function ValidCurveObject(ByVal s As Shape) As Boolean
    Select Case s.Type
        Case cdrRectangleShape, cdrPolygonShape, cdrPerfectShape, cdrEllipseShape, cdrCurveShape
            ValidCurveObject = True
        Case Else
            ValidCurveObject = False
    End Select
    
End Function

Private Function ValidTopObject(ByVal s As Shape) As Boolean
    Dim bValid As Boolean
    
    bValid = ValidCurveObject(s)
    
    If bValid Then
        bValid = (s.Outline.Type = cdrNoOutline) And (s.Fill.Type = cdrUniformFill)
    End If
    
    If bValid Then
        bValid = s.Fill.UniformColor.IsSame(CreateCMYKColor(0, 0, 0, 30))
    End If
    
    ValidTopObject = bValid
End Function

Private Function ValidBottomObject(ByVal s As Shape) As Boolean
    ValidBottomObject = s.Type <> cdrGroupShape
End Function

Private Function FindIntersections(ByVal crv1 As Curve, crv2 As Curve) As Boolean
    Dim sp1 As SubPath
    Dim sp2 As SubPath
    Dim bFound As Boolean
    
    bFound = False
    For Each sp1 In crv1.SubPaths
        For Each sp2 In crv2.SubPaths
            If sp1.GetIntersections(sp2).Count > 0 Then
                bFound = True
                Exit For
            End If
        Next sp2
        If bFound Then Exit For
    Next sp1
    
    FindIntersections = bFound
End Function

Private Function Overlap(ByVal s1 As Shape, ByVal s2 As Shape) As Boolean
    Dim x11 As Double, y11 As Double, x12 As Double, y12 As Double
    Dim w1 As Double, h1 As Double
    Dim x21 As Double, y21 As Double, x22 As Double, y22 As Double
    Dim w2 As Double, h2 As Double
    Dim x As Double, y As Double
    
    ' Get bounding boxes of the two shapes
    s1.GetBoundingBox x11, y11, w1, h1
    s2.GetBoundingBox x21, y21, w2, h2
    
    ' Calculate the bounding rectangle corner coordinates
    x12 = x11 + w1
    y12 = y11 + h1
    x22 = x12 + w2
    y22 = y12 + h2
    
    ' Find the intersection of the two rectangles
    If x11 < x21 Then x11 = x21
    If y11 < y21 Then y11 = y21
    If x12 > x22 Then x12 = x22
    If y12 > y22 Then y12 = y22
    
    ' See if there is intersection between the two bounding rectangles
    If x11 < x12 And y11 < y12 Then
        ' There might be an intersection
        ' Check if the back object is "normal" shape and we can do some more
        ' detailed analysis. If not, then bounding box check is all we can do
        If ValidCurveObject(s2) Then
            Overlap = FindIntersections(s1.DisplayCurve, s2.DisplayCurve)
            If Not Overlap Then
                ' If the objects do not intersect, it might be that the top
                ' object lies completely inside the bottom one
                ' Check to see if the at least one node of the top curve (s1)
                ' is inside the bottom one (s1)
                s1.DisplayCurve.Nodes(1).GetPosition x, y
                Overlap = (s2.IsOnShape(x, y) <> cdrOutsideShape)
            End If
        Else
            Overlap = True
        End If
    Else
        ' No intersection for sure
        Overlap = False
    End If
End Function
Reply With Quote
  #3  
Old 02-12-2011, 10:12
DecalPrint
Guest
 
Posts: n/a
Default

Hello, some times ago. Still testing. I have modified the ValidTopObject Function to this:

Private Function ValidTopObject(ByVal s As Shape) As Boolean
Dim bValid, b1valid As Boolean

bValid = ValidCurveObject(s)

If bValid = True Then
b1valid = (s.Fill.UniformColor.IsSame(CreateCMYKColor(0, 0, 0, 30))) And (s.Outline.Color.IsSame(CreateCMYKColor(0, 0, 0, 30)))
b1valid = ((s.Outline.Type = cdrNoOutline) And (s.Fill.Type = cdrUniformFill)) Or ((s.Outline.Type = cdrOutline) And (s.Fill.Type = cdrNoFill))
End If

ValidTopObject = b1valid
End Function

But it works not correct. I have attached a sample file in X5. I can´t define it, that objects are deleted who have 30K outline and 30K fill. If I define this with another OR, it deletes also the one object with 100K outline and 30K fill.
Where is the error?
Carsten
Attached Files
File Type: cdr sample2.cdr (14.8 KB, 119 views)
Reply With Quote
  #4  
Old 03-12-2011, 03:48
DecalPrint
Guest
 
Posts: n/a
Default

Oh, it deletes Objects, they are have 100K Outline/NoFill.
My thoughts..
True if it have
30k outline, no fill
no outline, 30k fill
30k outline, 30k fill

false if it have
100k outline, no fill
no outline, 100k fill
100k outline, 100k fill
30k outline, 100k fill
100k outline, 30k fill

Too heavy for define it by myself.
Reply With Quote
  #5  
Old 03-12-2011, 04:59
ippass
Guest
 
Posts: n/a
Default

Your thought:
My thoughts..
True if it have
30k outline, no fill
no outline, 30k fill
30k outline, 30k fill

false if it have
100k outline, no fill
no outline, 100k fill
100k outline, 100k fill
30k outline, 100k fill
100k outline, 30k fill

Your code should be:
Code:
Private Function ValidTopObject(ByVal s As Shape) As Boolean
Dim bValid, b1valid As Boolean

bValid = ValidCurveObject(s)

If bValid = True Then

b1valid =  (s.Outline.Color.IsSame(CreateCMYKColor(0, 0, 0, 30)) And (s.Fill.Type = cdrNoFill)) or _
    ((s.Outline.Type = cdrNoOutline) And s.Fill.UniformColor.IsSame(CreateCMYKColor(0, 0, 0, 30))) or _
    (s.Fill.UniformColor.IsSame(CreateCMYKColor(0, 0, 0, 30)) And s.Outline.Color.IsSame(CreateCMYKColor(0, 0, 0, 30))) 
Fill))
End If

ValidTopObject = b1valid
End Function
Reply With Quote
  #6  
Old 04-12-2011, 00:23
DecalPrint
Guest
 
Posts: n/a
Default

Ahh, Thank you Ippass, that´s much more better. It OK to work with this.
Now it don´t delete 1 free object with 30K outline and noFill in the sample file. But why?
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
what is the CQL syntax for selecting shapes of same color aakkaarr CorelDRAW/Corel DESIGNER VBA 1 21-09-2011 17:09


All times are GMT -5. The time now is 00:24.


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