Select Same Outline, Fill, Outline & Fill 2018

[dungbtl]

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

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