1
1

AutoCutLines.bas 2.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114
  1. Attribute VB_Name = "AutoCutLines"
  2. #If VBA7 Then
  3. Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
  4. #Else
  5. Private Declare Sub Sleep Lib "kernel32" (ByValdwMilliseconds As Long)
  6. #End If
  7. Public Sub AutoCutLines()
  8. Nodes_TO_TSP
  9. START_Cut_Line_Algorithm 3#
  10. '延时500毫秒,如果电脑够快,可以调整到100ms
  11. Sleep 500
  12. TSP_TO_DRAW_LINES
  13. End Sub
  14. Private Function Nodes_TO_TSP()
  15. On Error GoTo ErrorHandler
  16. API.BeginOpt "Nodes_TO_TSP"
  17. Set fs = CreateObject("Scripting.FileSystemObject")
  18. Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
  19. Dim s As Shape, ssr As ShapeRange
  20. Set ssr = ActiveSelectionRange
  21. Dim TSP As String
  22. TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
  23. For Each s In ssr
  24. lx = s.LeftX: rx = s.RightX
  25. By = s.BottomY: ty = s.TopY
  26. TSP = TSP & lx & " " & By & vbNewLine
  27. TSP = TSP & lx & " " & ty & vbNewLine
  28. TSP = TSP & rx & " " & By & vbNewLine
  29. TSP = TSP & rx & " " & ty & vbNewLine
  30. Next s
  31. f.WriteLine TSP
  32. f.Close
  33. '// 刷新一下文件流,延时的效果
  34. Set f = fs.OpenTextFile("C:\TSP\CDR_TO_TSP", 1, False)
  35. Dim str
  36. str = f.ReadAll()
  37. f.Close
  38. API.EndOpt
  39. Exit Function
  40. ErrorHandler:
  41. Application.Optimization = False
  42. On Error Resume Next
  43. End Function
  44. '// TSP功能画线-多线段
  45. Private Function TSP_TO_DRAW_LINES()
  46. On Error GoTo ErrorHandler
  47. API.BeginOpt "TSP_TO_DRAW_LINES"
  48. Set fs = CreateObject("Scripting.FileSystemObject")
  49. Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
  50. Dim str, arr, n
  51. Dim line As Shape
  52. str = f.ReadAll()
  53. f.Close
  54. Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
  55. str = f.ReadAll()
  56. str = VBA.Replace(str, vbNewLine, " ")
  57. Do While InStr(str, " ")
  58. str = VBA.Replace(str, " ", " ")
  59. Loop
  60. arr = Split(str)
  61. For n = 2 To UBound(arr) - 1 Step 4
  62. x = Val(arr(n))
  63. Y = Val(arr(n + 1))
  64. x1 = Val(arr(n + 2))
  65. y1 = Val(arr(n + 3))
  66. Set line = ActiveLayer.CreateLineSegment(x, Y, x1, y1)
  67. set_line_color line
  68. ' 调试线条顺序
  69. puts x, Y, (n + 2) / 4
  70. Next
  71. ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
  72. ActiveSelection.Group
  73. ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
  74. API.EndOpt
  75. Exit Function
  76. ErrorHandler:
  77. Application.Optimization = False
  78. On Error Resume Next
  79. End Function
  80. '// 运行裁切线算法 Cut_Line_Algorithm.py
  81. Private Function START_Cut_Line_Algorithm(Optional ext As Double = 3)
  82. cmd_line = "python C:\TSP\Cut_Line_Algorithm.py" & " " & ext
  83. Shell cmd_line
  84. End Function
  85. '// 设置线条标记(颜色)
  86. Private Function set_line_color(line As Shape)
  87. line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
  88. End Function
  89. Public Sub puts(x, Y, n)
  90. Dim st As String
  91. st = str(n)
  92. Set s = ActiveLayer.CreateArtisticText(x, Y, st)
  93. End Sub