OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > FAQ

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 27-04-2005, 13:39
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default How to select objects of the same color?

I have a complex document. I want to select all red objects. Is there a way?
Reply With Quote
  #2  
Old 30-06-2005, 02:02
sallybode
Guest
 
Posts: n/a
Default

Using color styles which is available in the dockers, by auto creating once launched your color styles you can then recolor those objects that are the specific color you are after.

I know this may not be what you are after, but it does allow to edit the color in some ways.
Reply With Quote
  #3  
Old 30-06-2005, 13:24
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default my macros

I assigned following macros to keyboard :
"F" for same fill select, "shift-F" same outline, (if capslock is on then some kind of tolerance may be specified)
I have a code (it's lame sometimes) but I use it very frequently and happy about it;-)

Code:
Sub selectSameFillColor() 
    selectSameColor True, False
End Sub
Sub selectSameFillAndOutline() 
    selectSameColor True, True
End Sub
Sub selectSameOutline() 
    selectSameColor False, True
End Sub

Private Sub selectSameColor(Optional checkFill As Boolean = True, _
                            Optional checkOutline As Boolean = False) 
    Dim shapeslist As New shapes
    Dim opts As New seekOpts

    If ActiveShape Is Nothing Then MsgBox "select a shape!", , "Warning": Exit Sub

   With opts
    s = "0"
    If GetKeyState(VK_CAPITAL) <> 0 Then
        s = InputBox("Difference allowed (0-100%):" & vbCrLf & "(Negative = select in groups)", "Select same color", 0)
        If s = "" Then Exit Sub
    End If
    .diff = Int(Val(s)): .selectInGroups = (.diff < 0): .diff = Abs(.diff)
    .groupsEncountered = False: .checkFill = checkFill: .checkOutline = checkOutline
    
    .seekShapeType = ActiveShape.Type
    Select Case .seekShapeType
        Case cdrCurveShape, cdrCustomShape, cdrEllipseShape, cdrPerfectShape, cdrPolygonShape, cdrRectangleShape, cdrTextShape
            If checkFill Then
                .seekFillType = ActiveShape.Fill.Type
                Select Case .seekFillType
                    Case cdrNoFill: '
                    Case cdrUniformFill, cdrMonoBitmapFill
                        Set opts.seekFillColor = New Color
                        .seekFillColor.CopyAssign ActiveShape.Fill.UniformColor
                        .seekFillColor.ConvertToCMYK
                    Case cdrFountainFill:
                    Case Else
                        MsgBox ("Unsupported type of fill."): Exit Sub
                End Select
            End If
            If checkOutline Then
                .seekOutlineType = ActiveShape.Outline.Type
                If .seekOutlineType <> cdrNoOutline Then
                    Set opts.seekOutlineColor = New Color
                    .seekOutlineColor.CopyAssign ActiveShape.Outline.Color
                    .seekOutlineColor.ConvertToCMYK
                End If
            End If
        Case Else
            .seekFillType = -1: .seekOutlineType = -1
    End Select
   End With 'opts
    
    boostStart
    On Error GoTo ErrHandler
    Set stat = Application.Status: stat.BeginProgress CanAbort:=True
    Set opts.foundShapes = New ShapeRange

    DoSelectColorOnShapes ActiveDocument.SelectableShapes, opts

    If opts.foundShapes Is Nothing Then ActiveDocument.ClearSelection else opts.foundShapes.CreateSelection
    
    If groupsEncountered Then _
        MsgBox "Groups were found with desired colors. DO UNGROUP.", vbOK, "Groups found"
ExitSub:
    stat.EndProgress
    boostFinish
    Exit Sub
ErrHandler:
    stat.EndProgress
    MsgBox "Unexpected error occured: " & ERR.Description & vbCrLf & ERR.source, vbCritical
    Resume ExitSub
End Sub

Private Sub DoSelectColorOnShapes(ByRef sh As shapes, ByRef opts As seekOpts) 
    Dim s As Shape, clr As New Color, pass As Boolean
    On Error Resume Next
    For Each s In sh
       With opts
        If .selectInGroups Then
            If s.Type = cdrGroupShape Then DoSelectColorOnShapes s.shapes, opts
            If Not s.PowerClip Is Nothing Then DoSelectColorOnShapes s.PowerClip.shapes, opts
        End If
        Select Case s.Type
            Case cdrCurveShape, cdrCustomShape, cdrEllipseShape, cdrPerfectShape, cdrPolygonShape, cdrRectangleShape, cdrTextShape
                If .checkFill And s.Fill.Type = .seekFillType Then
                    Select Case .seekFillType
                        Case cdrNoFill
                            If Not s.ParentGroup Is Nothing Then .groupsEncountered = True
                            opts.foundShapes.Add s
                        Case cdrUniformFill, cdrMonoBitmapFill
                            clr.CopyAssign s.Fill.UniformColor
                            If s.Fill.UniformColor.Type <> cdrColorCMYK Then: clr.ConvertToCMYK
                            If .diff = 0 Then
                                pass = clr.IsSame(.seekFillColor)
                            Else
                                pass = Abs(clr.CMYKCyan - .seekFillColor.CMYKCyan) <= .diff And _
                                     Abs(clr.CMYKMagenta - .seekFillColor.CMYKMagenta) <= .diff And _
                                     Abs(clr.CMYKYellow - .seekFillColor.CMYKYellow) <= .diff And _
                                     Abs(clr.CMYKBlack - .seekFillColor.CMYKBlack) <= .diff
                            End If
                            If pass Then
                                If Not s.ParentGroup Is Nothing Then groupsEncountered = True
                                opts.foundShapes.Add s
                            End If
                    End Select
                End If
                If .checkOutline And s.Outline.Type = .seekOutlineType Then
                    Select Case .seekOutlineType
                        Case cdrNoOutline
                            If Not s.ParentGroup Is Nothing Then .groupsEncountered = True
                            opts.foundShapes.Add s
                        Case cdrOutline
                            clr.CopyAssign s.Outline.Color
                            If s.Outline.Color.Type <> cdrColorCMYK Then: clr.ConvertToCMYK
                            If .diff = 0 Then
                                pass = clr.IsSame(.seekOutlineColor)
                            Else
                                pass = Abs(clr.CMYKCyan - .seekOutlineColor.CMYKCyan) <= .diff And _
                                     Abs(clr.CMYKMagenta - .seekOutlineColor.CMYKMagenta) <= .diff And _
                                     Abs(clr.CMYKYellow - .seekOutlineColor.CMYKYellow) <= .diff And _
                                     Abs(clr.CMYKBlack - .seekOutlineColor.CMYKBlack) <= .diff
                            End If
                            If pass Then
                                If Not s.ParentGroup Is Nothing Then groupsEncountered = True
                                opts.foundShapes.Add s
                            End If
                    End Select
                End If
            Case Else
                If s.Type = .seekShapeType Then
                    opts.foundShapes.Add s
                    If Not s.ParentGroup Is Nothing Then .groupsEncountered = True
                End If
        End Select
     End With
    Next s
End Sub

Public Sub boostStart(Optional ByVal unDo As String = "")
    If unDo <> "" Then ActiveDocument.BeginCommandGroup "Convert to CMYK"
    Optimization = True
    EventsEnabled = False
    ActiveDocument.SaveSettings
    ActiveDocument.PreserveSelection = False
End Sub

Public Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False)
    ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    Application.Refresh
    CorelDRAW.CorelScript.RedrawScreen
    If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub
Reply With Quote
  #4  
Old 05-07-2005, 23:52
GraphiXtreme
Guest
 
Posts: n/a
Default

I tried this and the following line had a compile error (User-defined type not defined). Any ideas (I am very poor at VBA)?

Private Sub DoSelectColorOnShapes(ByRef sh As shapes, ByRef opts As seekOpts)
Reply With Quote
  #5  
Old 07-07-2005, 09:37
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

the class "seekopts" must be defined in separate class module (in your project) named "seekopts": there you write this:
Code:
Public checkFill, checkOutline As Boolean
Public seekFillType As cdrFillType
Public seekOutlineType As cdrOutlineType
Public seekShapeType As cdrShapeType
Public seekFillColor, seekOutlineColor As Color
Public diff As Long
Public selectInGroups, groupsEncountered As Boolean
Public foundShapes As ShapeRange
now the class is created
Attached Images
 
Reply With Quote
  #6  
Old 07-07-2005, 15:09
GraphiXtreme
Guest
 
Posts: n/a
Default

I feel like such a boob...now I get a compile error: sub or function not defined. I wish I knew this stuff cuz I have need to make some things with VB, but don't know JACK about this stuff yet. I have a mechanical engineering degree, not computer programming, so I really struggle with this stuff. Sorry to be a PITA
Attached Images
 
Reply With Quote
  #7  
Old 08-07-2005, 00:42
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 Select Same Color

I was just working on another script for deleting objects of the same color, and thought, you know with a a few changes this could be made to work to select objects of the same color.

If you select a single shape, then run this script it will select all shapes with the same color and create a selection, you can then change the color or delete them. Hope you find it useful.

Code:
Sub SelectSameColor()

Dim os As Shape, s As Shape
Dim sr As New ShapeRange

If ActiveSelection.Shapes.Count = 0 Then
    MsgBox "Please select an object.", vbOKOnly
    Exit Sub
ElseIf ActiveSelection.Shapes.Count > 1 Then
    MsgBox "Please select only one object.", vbOKOnly
    Exit Sub
ElseIf ActiveSelection.Shapes.Count = 1 Then
    Set os = ActiveShape
End If

For Each s In ActivePage.Shapes
    If s.StaticID <> os.StaticID Then
        If s.Fill.UniformColor.IsSame(os.Fill.UniformColor) Then sr.add s
    End If
Next s

sr.add os
sr.CreateSelection
    
End Sub
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
Select Paragraph Text with more than one color joexx CorelDRAW/Corel DESIGNER VBA 2 06-10-2004 13:20
Select objects inside another shelbym CorelDRAW/Corel DESIGNER VBA 1 25-11-2003 17:01
Converting objects color properties jwknight CorelDRAW/Corel DESIGNER VBA 1 23-10-2003 11:03
replace objects of certain color jwknight CorelDRAW/Corel DESIGNER VBA 3 14-08-2003 13:43
VBA Script for CD 11 - Selecting objects with same color Superfreak CorelDRAW/Corel DESIGNER VBA 4 28-01-2003 12:33


All times are GMT -5. The time now is 07:17.


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