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 16-09-2018, 05:00
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
 
Join Date: Apr 2004
Posts: 137
Default Select Same Outline, Fill, Outline & Fill 2018

This code is outdated for 2018. Any conversion or something better?
Would like to be able to select either Fill or Outline or Both.

Code:
Public Declare Function GetAsyncKeyState& Lib "user32" (ByVal vKey&)

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 sr As ShapeRange, sh As Shape, clr As New Color, srg As ShapeRange
   Dim seekFillColor As New Color, seekOutlineColor As New Color
   Dim found As New ShapeRange, stat As AppStatus

   If ActiveShape Is Nothing Then Beep: Exit Sub

   s = "1"
   If (GetAsyncKeyState(&H91) And 1) <> 0 Then 'VK_SCROLL=0x91
      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)
   
   seekShapeType = ActiveShape.type: seekFillType = -1: seekOutlineType = -1
   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
                  seekFillColor.CopyAssign ActiveShape.Fill.UniformColor
                  If diff > 0 Then 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
               seekOutlineColor.CopyAssign ActiveShape.Outline.Color
               If diff > 0 Then seekOutlineColor.ConvertToCMYK
            End If
         End If
   End Select
   
   On Error GoTo ErrHandler: boostStart
   Set stat = Application.Status: stat.BeginProgress CanAbort:=True
   If Not selectInGroups Then
      Set srg = ActivePage.SelectableShapes.All
      srg.RemoveRange ActivePage.FindShapes(, cdrGroupShape, False)
      Set sr = srg.Shapes.FindShapes(, , False)
      Set srg = Nothing
   Else
      Set sr = ActivePage.FindShapes
   End If
   sr.AddRange ActiveDocument.pages(0).DesktopLayer.FindShapes(, , selectInGroups)
   For Each sh In sr
      Select Case sh.type
      Case cdrCurveShape, cdrCustomShape, cdrEllipseShape, cdrPerfectShape, _
           cdrPolygonShape, cdrRectangleShape, cdrTextShape
         passFill = False: passOutline = False
         If checkFill And sh.Fill.type = seekFillType Then
            Select Case seekFillType
               Case cdrNoFill
                  passFill = True
               Case cdrUniformFill, cdrMonoBitmapFill
                  If diff = 0 Then
                     passFill = sh.Fill.UniformColor.IsSame(seekFillColor)
                  Else
                     clr.CopyAssign sh.Fill.UniformColor
                     If clr.type <> cdrColorCMYK Then clr.ConvertToCMYK
                     'distance = clr.GetColorDistanceFrom(seekFillColor)
                     'MsgBox distance & vbCrLf & seekFillColor.ToString & vbCrLf & clr.ToString & vbCrLf & diff
                     'passFill = clr.GetColorDistanceFrom(seekFillColor) <= dist
                     passFill = diff >= Sqr((clr.CMYKCyan - seekFillColor.CMYKCyan) ^ 2 + _
                         (clr.CMYKMagenta - seekFillColor.CMYKMagenta) ^ 2 + _
                         (clr.CMYKYellow - seekFillColor.CMYKYellow) ^ 2 + _
                         (clr.CMYKBlack - seekFillColor.CMYKBlack) ^ 2)
                  End If
            End Select
         End If
         If checkOutline And sh.Outline.type = seekOutlineType Then
            Select Case seekOutlineType
               Case cdrNoOutline
                  passOutline = True
               Case cdrOutline
                  If diff = 0 Then
                     passOutline = sh.Outline.Color.IsSame(seekOutlineColor)
                  Else
                     clr.CopyAssign sh.Outline.Color
                     If clr.type <> cdrColorCMYK Then clr.ConvertToCMYK
                     'distance = clr.GetColorDistanceFrom(seekOutlineColor)
                     'passOutline = clr.GetColorDistanceFrom(seekOutlineColor) <= dist
                     passOutline = diff >= Sqr((clr.CMYKCyan - seekOutlineColor.CMYKCyan) ^ 2 + _
                         (clr.CMYKMagenta - seekOutlineColor.CMYKMagenta) ^ 2 + _
                         (clr.CMYKYellow - seekOutlineColor.CMYKYellow) ^ 2 + _
                         (clr.CMYKBlack - seekOutlineColor.CMYKBlack) ^ 2)
                  End If
            End Select
         End If
         If VBA.IIf(checkFill, passFill, True) And VBA.IIf(checkOutline, passOutline, True) _
            Then found.Add sh
      Case Else
         If sh.type = seekShapeType Then found.Add sh
      End Select
   Next sh
   If found Is Nothing _
      Then ActiveDocument.ClearSelection _
      Else found.CreateSelection
      
ExitSub:
   stat.EndProgress: boostFinish: Exit Sub
ErrHandler:
   MsgBox "Unexpected error occured: " & Err.Description & vbCrLf & Err.Source, vbCritical
   stat.EndProgress: Resume ExitSub
End Sub

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

Public Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False) ' =================================================================================================
   Dim cs As Object
   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   Application.Refresh
   ActiveWindow.Refresh
   Application.CorelScript.RedrawScreen
   If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub

Function keyPressed(ByVal key&) As Boolean
   keyPressed = (GetAsyncKeyState(key) And &HFFFF8000) <> 0
   End Function
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
How to copy fill color to outline aakkaarr CorelDRAW/Corel DESIGNER VBA 2 26-04-2017 04:16
select all shapes with outline and fill "none" buga Macros/Add-ons 12 20-01-2011 13:44
Find and delete objects with no fill or outline keytecstaff CorelDRAW/Corel DESIGNER VBA 17 23-06-2010 00:34
Duplicate, Move to Back , no fill, no outline gorgo2 Macros/Add-ons 3 18-05-2010 19:05
Create Ellipse with Fill & NO Outline dungbtl CorelDRAW/Corel DESIGNER VBA 3 10-11-2007 11:31


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


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