corelvba/module/智能查找.bas

Attribute VB_Name = "智能查找"
Sub 一键加点工具()
  Dim OrigSelection As ShapeRange
  Set OrigSelection = ActiveSelectionRange
  If OrigSelection.Count <> 0 Then
    OrigSelection.Copy
  Else
    MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
    Exit Sub
  End If
  
  ' 新建文件粘贴
  Dim doc1 As Document
  Set doc1 = CreateDocument
  ActiveLayer.Paste
  
  ' 转曲线，一键加粗小红点
  ActiveSelection.ConvertToCurves
  Call get_little_points
End Sub


Private Sub get_little_points()
  On Error GoTo ErrorHandler
  '// 代码运行时关闭窗口刷新
  Application.Optimization = True
  ActiveDocument.BeginCommandGroup  '一步撤消'
  
  red_point_Size = 0.3
  ActiveDocument.Unit = cdrMillimeter
  Dim OrigSelection As ShapeRange, grp1 As ShapeRange, sh As Shape
  Set OrigSelection = ActiveSelectionRange
  Set grp1 = OrigSelection.UngroupAllEx
  grp1.ApplyUniformFill CreateCMYKColor(50, 0, 0, 0)
  
  For Each sh In grp1
    sh.BreakApartEx
  Next sh
  
  ActiveDocument.ClearSelection
  Dim sr As ShapeRange
  Set sr = ActivePage.Shapes.FindShapes(Query:="@width < {" & red_point_Size & " mm} and @width > {0.1 mm} and @height <{" & red_point_Size & " mm} and @height >{0.1 mm}")
  If sr.Count <> 0 Then
    sr.CreateSelection
    Set sh = ActiveSelection.Group
    sh.Outline.SetProperties 0.03, Color:=CreateCMYKColor(0, 100, 100, 0)
    sr.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
    sh.Move 0, 0.015
    sh.Copy
  Else
    MsgBox "文件中小圆点足够大，不需要加粗!"
  End If

  ActivePage.Shapes.FindShapes(Query:="@colors.find(CMYK(50, 0, 0, 0))").CreateSelection
  ActiveSelection.Group
  
  ActiveDocument.EndCommandGroup
  Application.Optimization = False
  ActiveWindow.Refresh
  Application.Refresh
  Exit Sub
ErrorHandler:
  MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
  Application.Optimization = False
  On Error Resume Next
End Sub

Sub 文字转曲()
  Tools.TextShape_ConvertToCurves
End Sub