2022-08更新添加设置保存注册表

UI/CQL_FIND_UI.bas

@@ -1,3 +1,18 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CQL_FIND_UI 
+   Caption         =   "使剪贴板上的物件替换选择的目标物件"
+   ClientHeight    =   4575
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   7575
+   OleObjectBlob   =   "CQL_FIND_UI.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "CQL_FIND_UI"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
@@ -46,13 +61,15 @@ End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   If Button Then
-    mX = x
-    mY = y
+    mx = x
+    my = y
+
   End If
 End Sub
 
 Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   If Button Then
+  Debug.Print x, y
     Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + y
   End If

UI/CorelVBA.bas

@@ -1,5 +1,20 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CorelVBA 
+   Caption         =   "CorelVBA 青年节 By 蘭雅sRGB 2022"
+   ClientHeight    =   5415
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   7740
+   OleObjectBlob   =   "CorelVBA.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "CorelVBA"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
 #If VBA7 Then
-    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
     Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
@@ -55,8 +70,8 @@ End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   If Button Then
-    mX = x
-    mY = y
+    mx = x
+    my = y
   End If
 End Sub
 

UI/Replace_UI.bas

@@ -1,3 +1,18 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Replace_UI 
+   Caption         =   "使剪贴板上的物件替换选择的目标物件"
+   ClientHeight    =   4560
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   7590
+   OleObjectBlob   =   "Replace_UI.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "Replace_UI"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
@@ -47,8 +62,8 @@ End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   If Button Then
-    mX = x
-    mY = y
+    mx = x
+    my = y
   End If
 End Sub
 

UI/Toolbar.bas

@@ -1,3 +1,18 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Toolbar 
+   Caption         =   "Toolbar"
+   ClientHeight    =   3960
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   6750
+   OleObjectBlob   =   "Toolbar.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "ToolBar"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
@@ -18,10 +33,6 @@ Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
 
-Private Sub Close_Icon_Click()
-  Unload Me    ' 关闭
-End Sub
-
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
   Dim Hwnd As Long
@@ -35,20 +46,57 @@ Private Sub UserForm_Initialize()
   IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
   SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
   
+With Me
+  .StartUpPosition = 0
+  .Left = 400    ' 设置工具栏位置
+  .Top = 55
+  .Height = 30
+  .Width = 336
+End With
+
+  OutlineKey = True
+  OptKey = True
+
+  ' 读取角线设置
+  Bleed.Text = API.GetSet("Bleed")
+  Line_len.Text = API.GetSet("Line_len")
+  Outline_Width.Text = API.GetSet("Outline_Width")
+End Sub
+
+Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+    If Button Then
+        mx = x
+        my = y
+    End If
+    
   With Me
-  '  .StartUpPosition = 0
-  '  .Left = 500
-  '  .Top = 200
-    .Width = 378
-    .Height = 228
+    .Height = 30
   End With
-  
+
+End Sub
+
+Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    Me.Left = Me.Left - mx + x
+    Me.Top = Me.Top - my + y
+  End If
 End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Abs(x - 14) < 14 And Abs(y - 14) < 14 And Button = 2 Then
+    Me.Width = 336
+    OPEN_UI_BIG.Left = 322
+    UI.Visible = True
+    LOGO.Visible = False
+    X_EXIT.Visible = False
+    LEFT_BT.Visible = False
+    TOP_BT.Visible = False
+    Exit Sub
+  End If
+  
   If Button Then
-    mX = x
-    mY = y
+      mx = x
+      my = y
   End If
 End Sub
 
@@ -59,132 +107,178 @@ Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVa
   End If
 End Sub
 
-
-Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  Dim c As New Color
+  ' 定义图标坐标pos
   Dim pos_x As Variant
   Dim pos_y As Variant
-  pos_x = Array(307, 27)
-  pos_y = Array(64, 126, 188, 200)
-
-  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(0)) < 30 Then
-    Call copy_shape_replace
-  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(1)) < 30 Then
-    Call copy_shape_replace_resize
-  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(2)) < 30 Then
-    Call image_replace
-  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(3)) < 30 Then
-    CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
+  pos_y = Array(14)
+  pos_x = Array(14, 41, 67, 94, 121, 148, 174, 201, 228, 254, 281, 308, 334, 361, 388, 415, 441, 468, 495)
+
+  '//扩展键按钮优先  ①右键收缩工具栏   ②右键居中页面    ③右键尺寸取整数    ④右键单色黑中线标记  ⑤右键单色黑中线标记
+  If Abs(x - pos_x(0)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    Me.Width = 30
+    UI.Visible = False
+    LOGO.Visible = True
+    X_EXIT.Visible = True
+    Exit Sub
+
+  ElseIf Abs(x - pos_x(1)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    Tools.居中页面
+    Exit Sub
+
+  ElseIf Abs(x - pos_x(3)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    Tools.尺寸取整
+    Exit Sub
+  
+  ElseIf Abs(x - pos_x(5)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    自动中线色阶条.Auto_ColorMark_K
+    Exit Sub
+  
+  '//分分合合把几个功能按键合并到一起，定义到右键上
+  ElseIf Abs(x - pos_x(4)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    Tools.分分合合
+    Exit Sub
+  
+  ElseIf Abs(x - pos_x(6)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    调用多页合并工具
+  Exit Sub
+  
+  ElseIf Abs(x - pos_x(8)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    '// 扩展工具栏
+    Me.Height = 30 + 45
+  Exit Sub
+  
   End If
   
-  Replace_UI.Hide
-End Sub
-
-
-Private Sub image_replace()
-  On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  Dim image_path As String
-  image_path = API.GetClipBoardString
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim x As Double, y As Double
-  Set shs = ActiveSelection.Shapes
-  cnt = 0
-  For Each sh In shs
-    If cnt = 0 Then
-      ActiveDocument.ClearSelection
-      ActiveLayer.Import image_path
-      Set sc = ActiveSelection
-      cnt = 1
-    Else
-      sc.Duplicate 0, 0
-    End If
-    sh.GetPosition x, y
-    sc.SetPosition x, y
+  '// 鼠标单击按钮  按工具栏上图标正常功能
+  If Abs(x - pos_x(0)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    裁切线.start
     
-    sh.GetSize x, y
-    sc.SetSize x, y
-    sh.Delete
+  ElseIf Abs(x - pos_x(1)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    剪贴板尺寸建立矩形.start
     
-  Next sh
-
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
-ErrorHandler:
-    MsgBox "请先复制图片的完整路径，本工具能自动替换图片!"
-    Application.Optimization = False
-    On Error Resume Next
-End Sub
-
-Private Sub copy_shape_replace_resize()
-  On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim x As Double, y As Double
-  Set shs = ActiveSelection.Shapes
-  cnt = 0
-  For Each sh In shs
-    If cnt = 0 Then
-      Set sc = ActiveDocument.ActiveLayer.Paste
-      cnt = 1
-    Else
-      sc.Duplicate 0, 0
-    End If
-    sh.GetPosition x, y
-    sc.SetPosition x, y
+  ElseIf Abs(x - pos_x(2)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    裁切线.SelectLine_to_Cropline
     
-    sh.GetSize x, y
-    sc.SetSize x, y
-    sh.Delete
+  ElseIf Abs(x - pos_x(3)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    拼版裁切线.arrange
     
-  Next sh
-
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
-ErrorHandler:
-    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
-    Application.Optimization = False
-    On Error Resume Next
-End Sub
-
-
-Private Sub copy_shape_replace()
-  On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim x As Double, y As Double
-  Set shs = ActiveSelection.Shapes
-  cnt = 0
-  For Each sh In shs
-    If cnt = 0 Then
-      Set sc = ActiveDocument.ActiveLayer.Paste
-      cnt = 1
-    Else
-      sc.Duplicate 0, 0
-    End If
-    sh.GetPosition x, y
-    sc.SetPosition x, y
-    sh.Delete
-  Next sh
-
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
-ErrorHandler:
-    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
-    Application.Optimization = False
-    On Error Resume Next
+  ElseIf Abs(x - pos_x(4)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    拼版裁切线.Cut_lines
+    
+  ElseIf Abs(x - pos_x(5)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    自动中线色阶条.Auto_ColorMark
+    
+  ElseIf Abs(x - pos_x(6)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    智能群组和查找.智能群组
+    
+  ElseIf Abs(x - pos_x(7)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    CQL_FIND_UI.Show 0
+    
+  ElseIf Abs(x - pos_x(8)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    Replace_UI.Show 0
+    
+  ElseIf Abs(x - pos_x(9)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    Tools.TextShape_ConvertToCurves
+    
+  ElseIf Abs(x - pos_x(10)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    LEFT_BT.Visible = True
+    TOP_BT.Visible = True
+    
+  ElseIf Abs(x - pos_x(11)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    Me.Width = 30
+    OPEN_UI_BIG.Left = 61
+    UI.Visible = False
+    LOGO.Visible = True
+    X_EXIT.Visible = True
+  End If
+
 End Sub
 
+
+Private Sub X_EXIT_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub LEFT_BT_Click()
+  Tools.傻瓜火车排列
+End Sub
+
+Private Sub TOP_BT_Click()
+ Tools.傻瓜阶梯排列
+End Sub
+
+Private Sub 调用多页合并工具()
+  Dim value As Integer
+  value = GMSManager.RunMacro("合并多页工具", "合并多页运行.run")
+End Sub
+
+
+Private Sub CDR_TO_TSP_Click()
+  TSP.CDR_TO_TSP
+End Sub
+
+Private Sub START_TSP_Click()
+  TSP.START_TSP
+End Sub
+
+Private Sub PATH_TO_TSP_Click()
+  TSP.MAKE_TSP
+End Sub
+
+Private Sub QR2Vector_Click()
+  Tools.QRCode_to_Vector
+End Sub
+
+Private Sub TSP_TO_DRAW_LINE_Click()
+  TSP.TSP_TO_DRAW_LINE
+End Sub
+
+
+Private Sub BITMAP_MAKE_DOTS_Click()
+  TSP.BITMAP_MAKE_DOTS
+End Sub
+
+
+Private Sub CBPY01_Click()
+  Tools.Python脚本整理尺寸
+  Me.Height = 30
+End Sub
+
+Private Sub CBPY02_Click()
+  Tools.Python提取条码数字
+  Me.Height = 30
+End Sub
+
+Private Sub CBPY03_Click()
+  Tools.Python二维码QRCode
+  Tools.QRCode_replace
+End Sub
+
+
+Private Sub OPEN_UI_BIG_Click()
+  Unload Me
+  CorelVBA.Show 0
+End Sub
+
+Private Sub Settings_Click()
+  If 0 < Val(Bleed.Text) * Val(Line_len.Text) < 100 Then
+   SaveSetting "262235.xyz", "Settings", "Bleed", Bleed.Text
+   SaveSetting "262235.xyz", "Settings", "Line_len", Line_len.Text
+   SaveSetting "262235.xyz", "Settings", "Outline_Width", Outline_Width.Text
+  End If
+
+  Me.Height = 30
+End Sub
+
+Private Sub Tools_Icon_Click()
+  ' 调用语句
+  i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
+  Me.Height = 30
+End Sub
+
+Private Sub Split_Segment_Click()
+  Tools.Split_Segment
+  Me.Height = 30
+End Sub

module/API.bas

@@ -1,12 +1,28 @@
 Attribute VB_Name = "API"
+Public Function GetSet(s As String)
+  Bleed = Val(GetSetting("262235.xyz", "Settings", "Bleed", "2.0"))
+  Line_len = Val(GetSetting("262235.xyz", "Settings", "Line_len", "3.0"))
+  Outline_Width = Val(GetSetting("262235.xyz", "Settings", "Outline_Width", "0.2"))
+' Debug.Print Bleed, Line_len, Outline_Width
+
+  If s = "Bleed" Then
+    GetSet = Bleed
+  ElseIf s = "Line_len" Then
+    GetSet = Line_len
+  ElseIf s = "Outline_Width" Then
+    GetSet = Outline_Width
+  End If
+  
+End Function
+
 '// 获得剪贴板文本字符
 Public Function GetClipBoardString() As String
-    On Error Resume Next
-    Dim MyData As New DataObject
-    GetClipBoardString = ""
-    MyData.GetFromClipboard
-    GetClipBoardString = MyData.GetText
-    Set MyData = Nothing
+  On Error Resume Next
+  Dim MyData As New DataObject
+  GetClipBoardString = ""
+  MyData.GetFromClipboard
+  GetClipBoardString = MyData.GetText
+  Set MyData = Nothing
 End Function
 
 '// 文本字符复制到剪贴板

module/CorelVBA窗口.bas

@@ -1,6 +1,6 @@
-Attribute VB_Name = "CorelVBA窗口"
+Attribute VB_Name = "CorelVBA´°¿Ú"
 Public Sub start()
-  ToolBar.Show 0
+  Toolbar.Show 0
 ' CorelVBA.show 0
 End Sub
 

module/TSP.bas

@@ -0,0 +1,200 @@
+Attribute VB_Name = "TSP"
+Public Function CDR_TO_TSP()
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+  
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  
+  Dim TSP As String
+  TSP = shs.Count & " " & 0 & vbNewLine
+  For Each sh In shs
+    x = sh.CenterX
+    y = sh.CenterY
+    TSP = TSP & x & " " & y & vbNewLine
+  Next sh
+  
+  f.WriteLine TSP
+  f.Close
+  MsgBox "小圆点导出节点信息到数据文件!" & vbNewLine
+End Function
+
+
+Public Function PATH_TO_TSP()
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+  
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  
+  Dim TSP As String
+  TSP = shs.Count & " " & 0 & vbNewLine
+  For Each sh In shs
+    x = sh.CenterX
+    y = sh.CenterY
+    TSP = TSP & x & " " & y & vbNewLine
+  Next sh
+  
+  f.WriteLine TSP
+  f.Close
+  MsgBox "选择曲线导出节点信息到数据文件!" & vbNewLine
+End Function
+
+
+Public Function START_TSP()
+    cmd_line = "C:\TSP\CDR2TSP.exe C:\TSP\CDR_TO_TSP"
+    Shell cmd_line
+End Function
+
+Public Function TSP_TO_DRAW_LINE()
+ ' On Error GoTo ErrorHandler
+  ActiveDocument.Unit = cdrMillimeter
+  
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.OpenTextFile("C:\TSP\TSP.txt", 1, False)
+  Dim Str, arr, n
+  Str = f.ReadAll()
+  
+  Str = VBA.replace(Str, vbNewLine, " ")
+  Do While InStr(Str, "  ")
+      Str = VBA.replace(Str, "  ", " ")
+  Loop
+  
+  arr = Split(Str)
+  total = Val(arr(0))
+  
+  ReDim ce(total) As CurveElement
+  Dim crv As Curve
+  
+  ce(0).ElementType = cdrElementStart
+  ce(0).PositionX = 0
+  ce(0).PositionY = 0
+  
+  Dim x As Double
+  Dim y As Double
+  For n = 2 To UBound(arr) - 1 Step 2
+    x = Val(arr(n))
+    y = Val(arr(n + 1))
+  
+    ce(n / 2).ElementType = cdrElementLine
+    ce(n / 2).PositionX = x
+    ce(n / 2).PositionY = y
+  
+  Next
+  
+  Set crv = CreateCurve(ActiveDocument)
+  crv.CreateSubPathFromArray ce
+  ActiveLayer.CreateCurve crv
+  
+ErrorHandler:
+  On Error Resume Next
+End Function
+
+Public Function TSP_TO_DRAW_LINE_BAK()
+  On Error GoTo ErrorHandler
+  ActiveDocument.Unit = cdrMillimeter
+  
+  Dim Str, arr, n
+  Str = API.GetClipBoardString
+  Str = VBA.replace(Str, vbNewLine, " ")
+  Do While InStr(Str, "  ")
+      Str = VBA.replace(Str, "  ", " ")
+  Loop
+  
+  arr = Split(Str)
+  total = Val(arr(0))
+  
+  ReDim ce(total) As CurveElement
+  Dim crv As Curve
+  
+  ce(0).ElementType = cdrElementStart
+  ce(0).PositionX = 0
+  ce(0).PositionY = 0
+  
+  Dim x As Double
+  Dim y As Double
+  For n = 2 To UBound(arr) - 1 Step 2
+    x = Val(arr(n))
+    y = Val(arr(n + 1))
+  
+    ce(n / 2).ElementType = cdrElementLine
+    ce(n / 2).PositionX = x
+    ce(n / 2).PositionY = y
+  
+  Next
+  
+  Set crv = CreateCurve(ActiveDocument)
+  crv.CreateSubPathFromArray ce
+  ActiveLayer.CreateCurve crv
+  
+ErrorHandler:
+  On Error Resume Next
+End Function
+
+
+Public Function MAKE_TSP()
+    cmd_line = "C:\TSP\TSP.exe"
+    Shell cmd_line
+End Function
+
+' 位图制作小圆点
+Public Function BITMAP_MAKE_DOTS()
+ ' On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup: Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  Dim line, art, n, h, w
+  Dim x As Double
+  Dim y As Double
+  Dim s As Shape
+  flag = 0
+  
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.OpenTextFile("C:\TSP\BITMAP", 1, False)
+
+  line = f.ReadLine()
+  Debug.Print line
+
+  ' 读取第一行，位图 h高度 和 w宽度
+  arr = Split(line)
+  h = Val(arr(0)): w = Val(arr(1))
+  
+  If h * w > 40000 Then
+      MsgBox "位图转换后的小圆点数量比较多:" & vbNewLine & h & " x " & w & " = " & h * w
+      flag = 1
+  End If
+
+  For i = 1 To h
+    line = f.ReadLine()
+    arr = Split(line)
+    For n = LBound(arr) To UBound(arr)
+      If arr(n) > 0 Then
+        x = n: y = -i
+        If flag = 1 Then
+          Set s = ActiveLayer.CreateRectangle2(x, y, 0.6, 0.6)
+        Else
+          make_dots x, y
+        End If
+      End If
+    Next n
+  Next i
+
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh: Application.Refresh
+Exit Function
+ErrorHandler:
+    Application.Optimization = False
+    On Error Resume Next
+End Function
+
+Private Function make_dots(x As Double, y As Double)
+  Dim s As Shape
+  Dim c As Variant
+  c = Array(0, 255, 0)
+  Set s = ActiveLayer.CreateEllipse2(x, y, 0.5, 0.5)
+  s.Fill.UniformColor.RGBAssign c(Int(Rnd() * 2)), c(Int(Rnd() * 2)), c(Int(Rnd() * 2))
+  s.Outline.Width = 0#
+End Function

module/Tools.bas

@@ -28,9 +28,12 @@ Public Function 傻瓜火车排列()
 ' X4 不支持 ShapeRange.sort
 #End If
 
-  ActiveDocument.ReferencePoint = cdrBottomLeft
+  ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
+    '' 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
+    '' 改成顶对齐 2022-08-10
+    ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).TopY
     cnt = cnt + 1
   Next s
 
@@ -80,7 +83,7 @@ Public Function TextShape_ConvertToCurves()
   ActiveWindow.Refresh:    Application.Refresh
 End Function
 
-
+'' 复制物件
 Public Function copy_shape()
   Dim OrigSelection As ShapeRange
   Set OrigSelection = ActiveSelectionRange
@@ -88,7 +91,7 @@ Public Function copy_shape()
 
 End Function
 
-
+'' 旋转物件角度
 Public Function Rotate_Shapes(n As Double)
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
@@ -105,6 +108,7 @@ Public Function Rotate_Shapes(n As Double)
   ActiveWindow.Refresh:    Application.Refresh
 End Function
 
+'' 得到物件尺寸
 Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
   ActiveDocument.Unit = cdrMillimeter
   Dim sh As ShapeRange
@@ -115,6 +119,7 @@ Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
   sy = Int(sy * 100 + 0.5) / 100
 End Function
 
+'' 批量设置物件尺寸
 Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
@@ -187,6 +192,7 @@ Public Function Python二维码QRCode()
     Shell cmd_line
 End Function
 
+'' QRCode二维码制作
 Public Function QRCode_replace()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -214,17 +220,18 @@ Public Function QRCode_replace()
     sh.Delete
     
   Next sh
-
+  
     '// 代码操作结束恢复窗口刷新
     ActiveDocument.EndCommandGroup
     Application.Optimization = False
     ActiveWindow.Refresh:    Application.Refresh
 Exit Function
 ErrorHandler:
-    Application.Optimization = False
-    On Error Resume Next
+  Application.Optimization = False
+  On Error Resume Next
 End Function
 
+'' QRCode二维码转矢量图
 Public Function QRCode_to_Vector()
   On Error GoTo ErrorHandler
   
@@ -236,9 +243,37 @@ Public Function QRCode_to_Vector()
     .DeleteOriginalObject = True
     .Finish
   End With
+ 
+Exit Function
+ErrorHandler:
+    On Error Resume Next
+End Function
 
+'' 选择多物件，组合然后拆分线段，为角线爬虫准备
+Public Function Split_Segment()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  Dim s As Shape
+  Dim nr As NodeRange
+  Dim nd As Node
+  
+  Set s = ssr.Combine
+  Set nr = s.Curve.Nodes.All
   
+  nr.BreakApart
+  s.BreakApartEx
+'  For Each nd In nr
+'    nd.BreakApart
+'  Next nd
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
 Exit Function
 ErrorHandler:
-    On Error Resume Next
+  Application.Optimization = False
+  On Error Resume Next
 End Function

module/convert.py

@@ -0,0 +1,40 @@
+import os
+import chardet
+import codecs
+
+
+def WriteFile(filePath, u, encoding="utf-8"):
+    with codecs.open(filePath, "w", encoding) as f:
+        f.write(u)
+
+
+def GBK_2_UTF8(src, dst):
+    #     检测编码，coding可能检测不到编码，有异常
+    f = open(src, "rb")
+    coding = chardet.detect(f.read())["encoding"]
+    f.close()
+    if coding != "utf-8":
+        with codecs.open(src, "r", coding) as f:
+            try:
+                WriteFile(dst, f.read(), encoding="utf-8")
+                try:
+                    print(src + "  " + coding + " to utf-8  converted!")
+                except Exception:
+                    print("print error")
+            except Exception:
+                print(src +"  "+ coding+ "  read error")
+
+# 把目录中的*.bas编码由gbk转换为utf-8
+def ReadDirectoryFile(rootdir):
+    for parent, dirnames, filenames in os.walk(rootdir):
+        for dirname in dirnames:
+          	#递归函数，遍历所有子文件夹
+            ReadDirectoryFile(dirname)
+        for filename in filenames:
+            if filename.endswith(".bas"):
+                GBK_2_UTF8(os.path.join(parent, filename),
+                           os.path.join(parent, filename))
+
+if __name__ == "__main__":
+    src_path = "R:/corelvba/module"
+    ReadDirectoryFile(src_path)

module/拼版裁切线.bas

@@ -21,7 +21,11 @@ Sub Cut_lines()
   set_lx = OrigSelection.LeftX:   set_rx = OrigSelection.RightX
   set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
   set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
-  radius = 8:  border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
+  radius = 8
+  Bleed = API.GetSet("Bleed")
+  Line_len = API.GetSet("Line_len")
+  Outline_Width = API.GetSet("Outline_Width")
+  border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
   
   ' 创建边界矩形，用来添加角线
   Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
@@ -57,7 +61,7 @@ Sub Cut_lines()
   '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
   ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
   ActiveSelection.Group
-  ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
+  ActiveSelection.Outline.SetProperties Outline_Width, Color:=CreateRegistrationColor
   
   ActiveDocument.EndCommandGroup
   '// 代码操作结束恢复窗口刷新
@@ -66,24 +70,24 @@ Sub Cut_lines()
   Application.Refresh
 End Sub
 
-'范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
+'范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
 Private Function draw_line(dot As Coordinate, border As Variant)
-    Bleed = 2:  line_len = 3:  radius = border(6)
+    radius = border(6): Bleed = border(7):  Line_len = border(8)
     Dim line As Shape
 
     If Abs(dot.y - border(3)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (line_len + Bleed))
+        Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (Line_len + Bleed))
         set_line_color line
     ElseIf Abs(dot.y - border(2)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (line_len + Bleed))
+        Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (Line_len + Bleed))
         set_line_color line
     End If
     
     If Abs(dot.x - border(1)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (line_len + Bleed), dot.y)
+        Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (Line_len + Bleed), dot.y)
         set_line_color line
     ElseIf Abs(dot.x - border(0)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (line_len + Bleed), dot.y)
+        Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (Line_len + Bleed), dot.y)
         set_line_color line
     End If
 
@@ -91,29 +95,29 @@ End Function
 
 '// 旧版本
 Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
-    Bleed = 2:  line_len = 3:  radius = border(6)
+    Bleed = 2:  Line_len = 3:  radius = border(6)
     Dim line As Shape
 
     If Abs(dot.y - border(3)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y + Bleed, dot.x, dot.y + (line_len + Bleed))
+        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y + Bleed, dot.x, dot.y + (Line_len + Bleed))
         set_line_color line
     ElseIf Abs(dot.y - border(2)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y - Bleed, dot.x, dot.y - (line_len + Bleed))
+        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y - Bleed, dot.x, dot.y - (Line_len + Bleed))
         set_line_color line
     End If
     
     If Abs(dot.x - border(1)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.y, dot.x + (line_len + Bleed), dot.y)
+        Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.y, dot.x + (Line_len + Bleed), dot.y)
         set_line_color line
     ElseIf Abs(dot.x - border(0)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.y, dot.x - (line_len + Bleed), dot.y)
+        Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.y, dot.x - (Line_len + Bleed), dot.y)
         set_line_color line
     End If
 
 End Function
 
 Private Function set_line_color(line As Shape)
-    '// 设置线宽和注册色
+    '// 设置轮廓线注册色
    line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
 End Function
 

module/自动中线色阶条.bas

@@ -168,7 +168,7 @@ Private Function put_page_size()
     ' 添加文字 页面大小和文件名
     Dim st As Shape
     size = Trim(Str(Int(ActivePage.SizeWidth))) + "x" + Trim(Str(Int(ActivePage.SizeHeight))) + "mm"
-    size = size & " " & ActiveDocument.FileName & " " & Date & vbNewLine & "Https://262235.xyz 需要您的支持!"
+    size = size & " " & ActiveDocument.FileName & " " & Date '   & vbNewLine & "Https://262235.xyz 需要您的支持!"
     Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
 End Function
 

module/裁切线.bas

@@ -6,10 +6,11 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
   Application.Optimization = True
   ActiveDocument.BeginCommandGroup  '一步撤消'
 
-   '// 设置当前文档 尺寸单位mm 出血和线长
+   '// 设置当前文档 尺寸单位mm 出血和线长和线宽
   ActiveDocument.Unit = cdrMillimeter
-  Bleed = 2
-  line_len = 3
+  Bleed = API.GetSet("Bleed")
+  Line_len = API.GetSet("Line_len")
+  Outline_Width = API.GetSet("Outline_Width")
 
   Dim OrigSelection As ShapeRange
   Set OrigSelection = ActiveSelectionRange
@@ -26,22 +27,22 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
       
       '//  添加裁切线，分别左下-右下-左上-右上
       Dim s2, s3, s4, s5, s6, s7, s8, s9 As Shape
-      Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + line_len), by)
-      Set s3 = ActiveLayer.CreateLineSegment(lx, by - Bleed, lx, by - (Bleed + line_len))
+      Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + Line_len), by)
+      Set s3 = ActiveLayer.CreateLineSegment(lx, by - Bleed, lx, by - (Bleed + Line_len))
 
-      Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, by, rx + (Bleed + line_len), by)
-      Set s5 = ActiveLayer.CreateLineSegment(rx, by - Bleed, rx, by - (Bleed + line_len))
+      Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, by, rx + (Bleed + Line_len), by)
+      Set s5 = ActiveLayer.CreateLineSegment(rx, by - Bleed, rx, by - (Bleed + Line_len))
 
-      Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + line_len), ty)
-      Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + line_len))
+      Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + Line_len), ty)
+      Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + Line_len))
 
-      Set s8 = ActiveLayer.CreateLineSegment(rx + Bleed, ty, rx + (Bleed + line_len), ty)
-      Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + line_len))
+      Set s8 = ActiveLayer.CreateLineSegment(rx + Bleed, ty, rx + (Bleed + Line_len), ty)
+      Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + Line_len))
 
       '// 选中裁切线 群组 设置线宽和注册色
       ActiveDocument.AddToSelection s2, s3, s4, s5, s6, s7, s8, s9
       ActiveSelection.Group
-      ActiveSelection.Outline.SetProperties 0.1
+      ActiveSelection.Outline.SetProperties Outline_Width
       ActiveSelection.Outline.SetProperties Color:=CreateRegistrationColor
   
   Next Target
@@ -67,8 +68,9 @@ Sub SelectLine_to_Cropline()
   '// 获得页面中心点 x,y
   px = ActiveDocument.Pages.First.CenterX
   py = ActiveDocument.Pages.First.CenterY
-  Bleed = 2
-  line_len = 3
+  Bleed = API.GetSet("Bleed")
+  Line_len = API.GetSet("Line_len")
+  Outline_Width = API.GetSet("Outline_Width")
   
   Dim s As Shape
   Dim line As Shape
@@ -90,9 +92,9 @@ Sub SelectLine_to_Cropline()
      If sh <= sw Then
       s.Delete
       If cx < px Then
-          Set line = ActiveLayer.CreateLineSegment(0, cy, 0 + line_len, cy)
+          Set line = ActiveLayer.CreateLineSegment(0, cy, 0 + Line_len, cy)
       Else
-          Set line = ActiveLayer.CreateLineSegment(px * 2, cy, px * 2 - line_len, cy)
+          Set line = ActiveLayer.CreateLineSegment(px * 2, cy, px * 2 - Line_len, cy)
       End If
      End If
    
@@ -100,13 +102,13 @@ Sub SelectLine_to_Cropline()
      If sh > sw Then
       s.Delete
       If cy < py Then
-          Set line = ActiveLayer.CreateLineSegment(cx, 0, cx, 0 + line_len)
+          Set line = ActiveLayer.CreateLineSegment(cx, 0, cx, 0 + Line_len)
       Else
-          Set line = ActiveLayer.CreateLineSegment(cx, py * 2, cx, py * 2 - line_len)
+          Set line = ActiveLayer.CreateLineSegment(cx, py * 2, cx, py * 2 - Line_len)
       End If
      End If
   
-      line.Outline.SetProperties 0.1
+      line.Outline.SetProperties Outline_Width
       line.Outline.SetProperties Color:=CreateRegistrationColor
   Next s