Create get_little_points.bas

get_little_points.bas

@@ -0,0 +1,54 @@
+Sub 一键加点工具()
+    Dim OrigSelection As ShapeRange
+    Set OrigSelection = ActiveSelectionRange
+    OrigSelection.Copy
+    
+    ' 新建文件粘贴
+    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
+  
+  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}").CreateSelection
+  Set sh = ActiveSelection.Group
+  sh.Outline.SetProperties 0.03, Color:=CreateCMYKColor(0, 100, 100, 0)
+  
+  Set OrigSelection = ActiveSelectionRange
+  OrigSelection.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
+  sh.Move 0, 0.015
+  
+  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