corelvba/module/AutoCutLines.bas

Attribute VB_Name = "AutoCutLines"
#If VBA7 Then
  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
  Private Declare Sub Sleep Lib "kernel32" (ByValdwMilliseconds As Long)
#End If

Public Sub AutoCutLines()
  Nodes_TO_TSP
  START_Cut_Line_Algorithm 3#
  
  '延时500毫秒，如果电脑够快，可以调整到100ms
  Sleep 500
  TSP_TO_DRAW_LINES
End Sub

Private Function Nodes_TO_TSP()
  On Error GoTo ErrorHandler
  API.BeginOpt "Nodes_TO_TSP"
  
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)

  Dim s As Shape, ssr As ShapeRange
  Set ssr = ActiveSelectionRange

  Dim TSP As String
  TSP = (ssr.Count * 4) & " " & 0 & vbNewLine

  For Each s In ssr
      lx = s.LeftX:   rx = s.RightX
      By = s.BottomY: ty = s.TopY
      TSP = TSP & lx & " " & By & vbNewLine
      TSP = TSP & lx & " " & ty & vbNewLine
      TSP = TSP & rx & " " & By & vbNewLine
      TSP = TSP & rx & " " & ty & vbNewLine
  Next s
  f.WriteLine TSP
  f.Close
  
  '// 刷新一下文件流，延时的效果
  Set f = fs.OpenTextFile("C:\TSP\CDR_TO_TSP", 1, False)
  Dim str
  str = f.ReadAll()
  f.Close
  
  API.EndOpt
Exit Function
ErrorHandler:
    Application.Optimization = False
    On Error Resume Next
End Function

'//  TSP功能画线-多线段
Private Function TSP_TO_DRAW_LINES()
  On Error GoTo ErrorHandler
  API.BeginOpt "TSP_TO_DRAW_LINES"
  
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
  Dim str, arr, n
  Dim line As Shape
  str = f.ReadAll()
  f.Close
  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
  str = f.ReadAll()
  
  str = VBA.Replace(str, vbNewLine, " ")
  Do While InStr(str, "  ")
    str = VBA.Replace(str, "  ", " ")
  Loop
  
  arr = Split(str)
  For n = 2 To UBound(arr) - 1 Step 4
    x = Val(arr(n))
    Y = Val(arr(n + 1))
    x1 = Val(arr(n + 2))
    y1 = Val(arr(n + 3))

    Set line = ActiveLayer.CreateLineSegment(x, Y, x1, y1)
    set_line_color line
    
    ' 调试线条顺序
    puts x, Y, (n + 2) / 4
    
  Next
  
  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
  ActiveSelection.Group
  ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
  
  API.EndOpt
Exit Function
ErrorHandler:
    Application.Optimization = False
    On Error Resume Next
End Function

'// 运行裁切线算法 Cut_Line_Algorithm.py
Private Function START_Cut_Line_Algorithm(Optional ext As Double = 3)
    cmd_line = "python C:\TSP\Cut_Line_Algorithm.py" & " " & ext
    Shell cmd_line
End Function

'// 设置线条标记(颜色)
Private Function set_line_color(line As Shape)
  line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
End Function

Public Sub puts(x, Y, n)
  Dim st As String
  st = str(n)
  Set s = ActiveLayer.CreateArtisticText(x, Y, st)
End Sub