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