1
1

get_little_points.bas 1.8 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859
  1. Sub 一键加点工具()
  2. Dim OrigSelection As ShapeRange
  3. Set OrigSelection = ActiveSelectionRange
  4. OrigSelection.Copy
  5. ' 新建文件粘贴
  6. Dim doc1 As Document
  7. Set doc1 = CreateDocument
  8. ActiveLayer.Paste
  9. ' 转曲线,一键加粗小红点
  10. ActiveSelection.ConvertToCurves
  11. Call get_little_points
  12. End Sub
  13. Private Sub get_little_points()
  14. On Error GoTo ErrorHandler
  15. '// 代码运行时关闭窗口刷新
  16. Application.Optimization = True
  17. ActiveDocument.BeginCommandGroup '一步撤消'
  18. red_point_Size = 0.3
  19. ActiveDocument.Unit = cdrMillimeter
  20. Dim OrigSelection As ShapeRange, grp1 As ShapeRange, sh As Shape
  21. Set OrigSelection = ActiveSelectionRange
  22. Set grp1 = OrigSelection.UngroupAllEx
  23. grp1.ApplyUniformFill CreateCMYKColor(50, 0, 0, 0)
  24. For Each sh In grp1
  25. sh.BreakApartEx
  26. Next sh
  27. ActiveDocument.ClearSelection
  28. Dim sr As ShapeRange
  29. 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}")
  30. If sr.Count <> 0 Then
  31. sr.CreateSelection
  32. Set sh = ActiveSelection.Group
  33. sh.Outline.SetProperties 0.03, Color:=CreateCMYKColor(0, 100, 100, 0)
  34. sr.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
  35. sh.Move 0, 0.015
  36. Else
  37. MsgBox "文件中小圆点足够大,不需要加粗!"
  38. End If
  39. ActivePage.Shapes.FindShapes(Query:="@colors.find(CMYK(50, 0, 0, 0))").CreateSelection
  40. ActiveSelection.Group
  41. ActiveDocument.EndCommandGroup
  42. Application.Optimization = False
  43. ActiveWindow.Refresh
  44. Application.Refresh
  45. Exit Sub
  46. ErrorHandler:
  47. MsgBox "选择水洗标要加点部分,然后点击【加点工具】按钮!"
  48. Application.Optimization = False
  49. On Error Resume Next
  50. End Sub