更新尺寸标注统一长宽节点合并

README.md

@@ -4,9 +4,12 @@
 # [CorelDRAW VBA](https://262235.xyz/index.php/tag/vba/)
 ![](https://262235.xyz/usr/uploads/2022/03/525753621.webp)
 
-## 蘭雅CorelVBA 中秋版0909 免费下载
+## [蘭雅CorelVBA 中秋版0909 免费下载](https://262235.xyz/262235_GMS_0909.7z)
 ### https://262235.xyz/262235_GMS_0909.7z
 
+## [蘭雅CorelVBA--基本工具栏导览演示](https://www.bilibili.com/video/BV1ZV4y1w7Lj)
+### https://www.bilibili.com/video/BV1ZV4y1w7Lj
+
 ## 蘭雅CorelVBA工具中秋预览版 [安装视频点击](https://262235.xyz/CorelVBA/install.mp4)
 - 以 CorelDRAW X6 举例
 ### 1. 解压压缩包 蘭雅CorelVBA工具中秋预览版.7z
@@ -25,7 +28,13 @@
 ## 蘭雅CorelVBA工具中秋版 修复更新和添加的主要功能
 
 ```
-* 8215267 (HEAD -> main, origin/main, origin/HEAD) 蘭雅CorelVBA工具 UI独立图片 添加语音功能提示
+* 2022.12.23 更新尺寸标注统一长宽节点合并
+* 92a90b0 2022.12.09更新,增加安全辅助线和批量多页居中功能
+* 93670b7 贪心商人TSP升级
+* e1c342c 一刀切升级，Python工具源码加入
+* 2a8eb82 UI独立图片，工具栏三个皮肤，鼠标悬停五彩斑斓的黑
+* 8215267 蘭雅CorelVBA工具 UI独立图片 添加语音功能提示
+* 8215267 蘭雅CorelVBA工具 UI独立图片 添加语音功能提示
 * 1457811 蘭雅CorelVBA工具-中秋版 更换UI图
 * 0f35182 简单一刀切_识别群组由群友宏瑞广告赞助发行
 * b2eb2c4 一键智能群组--功能由群友半缘君赞助发行

UI/Make_SIZE.bas

@@ -0,0 +1,245 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Make_SIZE 
+   Caption         =   " 标注尺寸"
+   ClientHeight    =   1515
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   3690
+   OleObjectBlob   =   "Make_SIZE.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "Make_SIZE"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub UserForm_Initialize()
+    With Tis
+        .BackColor = RGB(0, 150, 255)
+        .BorderColor = RGB(30, 150, 255)
+        .ForeColor = RGB(255, 255, 255)
+    End With
+End Sub
+
+Private Function 按钮移入(T)
+    With T
+        .BackColor = RGB(0, 150, 255)
+        .BorderColor = RGB(30, 150, 255)
+        .ForeColor = RGB(255, 255, 255)
+    End With
+End Function
+
+Private Function 命令按钮(T As Label)
+    With T
+        .BackColor = RGB(240, 240, 240)
+        .BorderColor = RGB(100, 100, 100)
+        .ForeColor = RGB(0, 0, 0)
+    End With
+End Function
+
+Private Sub CheckBox1_Click()
+    If CheckBox1 Then CheckBox4 = False
+End Sub
+
+Private Sub CheckBox2_Click()
+    If CheckBox2 Then CheckBox4 = False
+End Sub
+
+Private Sub CheckBox3_Click()
+    If CheckBox3 Then CheckBox1 = False: CheckBox2 = False: CheckBox4 = False
+End Sub
+
+Private Sub CheckBox4_Click()
+    If CheckBox4 Then CheckBox1 = False: CheckBox2 = False: CheckBox3 = False
+End Sub
+
+Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Call 命令按钮(标注)
+    Call 命令按钮(删除)
+End Sub
+
+Private Sub SpinButton1_SpinDown()
+    选中标注字号减少
+End Sub
+
+Private Sub SpinButton1_SpinUp()
+    选中标注字号增加
+End Sub
+
+Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
+    选中标注字号
+End Sub
+
+Private Sub 标注_Click()
+    If CheckBox1 Or CheckBox2 Then Call 标注宽高度
+    If CheckBox3 Then Call 标注线长
+    If CheckBox4 Then Call 标注线段长
+End Sub
+
+Private Sub 标注_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Call 按钮移入(标注)
+End Sub
+
+Private Sub 删除_Click()
+    删除标注
+End Sub
+
+Private Sub 删除_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Call 按钮移入(删除)
+End Sub
+
+
+Private Sub 标注宽高度()
+    ActiveDocument.Unit = cdrMillimeter
+    Dim s As Shape, st1 As Shape, st2 As Shape
+    Set s = ActiveShape
+    If s Is Nothing Then Exit Sub
+    Optimization = True '优化启动
+    For Each s In ActiveSelection.Shapes
+        If CheckBox1 Then
+            Set st1 = ActiveLayer.CreateArtisticText(s.LeftX, s.TopY + 4, round(s.SizeWidth, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
+                st1.text.Story.CharSpacing = 0 '字符间距
+                st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
+                st1.Move s.SizeWidth / 2, 0
+                st1.Name = "Text" ' 设置名
+            Set sox = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 3, s.RightX, s.TopY + 3)
+                sox.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                sox.Name = "line"
+            Set sox1 = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 1, s.LeftX, s.TopY + 3)
+                sox1.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                sox1.Name = "line"
+            Set sox2 = ActiveLayer.CreateLineSegment(s.RightX, s.TopY + 1, s.RightX, s.TopY + 3)
+                sox2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                sox2.Name = "line"
+            s.CreateSelection
+        End If
+        If CheckBox2 Then
+            Set st2 = ActiveLayer.CreateArtisticText(s.LeftX - 4, s.BottomY, round(s.SizeHeight, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
+            st2.text.Story.CharSpacing = 0 '字符间距
+            st2.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
+            st2.Rotate 90
+            st2.Move -st2.SizeWidth / 2, s.SizeHeight / 2
+            st2.Name = "Text" ' 设置名
+            Set soy = ActiveLayer.CreateLineSegment(s.LeftX - 3, s.BottomY, s.LeftX - 3, s.TopY)
+                soy.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                soy.Name = "line"
+            Set soy1 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.BottomY, s.LeftX - 3, s.BottomY)
+                soy1.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                soy1.Name = "line"
+            Set soy2 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.TopY, s.LeftX - 3, s.TopY)
+                soy2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
+                soy2.Name = "line"
+            s.CreateSelection
+        End If
+    Next
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 标注线段长()
+    ActiveDocument.Unit = cdrMillimeter
+    Dim s As Shape, s1 As Shape, s2 As Shape, sc As Shape, st1 As Shape, st2 As Shape
+    Set s = ActiveShape
+    If s Is Nothing Then Exit Sub
+    Optimization = True '优化启动
+    For Each s In ActiveSelection.Shapes
+        If s.Type <> cdrTextShape Then
+            s.Copy
+            Set sc = ActiveLayer.Paste
+            sc.ConvertToCurves
+            sc.Curve.Nodes.All.BreakApart
+            sc.BreakApart
+            For Each s1 In ActiveSelection.Shapes
+                Set st1 = ActiveLayer.CreateArtisticText(0, 0, round(s1.Curve.Length, 0), , , , TextBox1.value)
+                st1.text.Story.CharSpacing = 0 '字符间距
+                st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
+                st1.text.FitToPath s1
+                ' 获取或设置文本与路径的偏移量
+                st1.Effects(1).TextOnPath.Offset = s1.Curve.Length * 0.5 - st1.SizeWidth * 0.55
+                ' 获取或设置文本与路径的距离
+                st1.Effects(1).TextOnPath.DistanceFromPath = 1
+                st1.Name = "Text" ' 设置名
+                s1.Outline.SetNoOutline
+                s1.OrderToBack
+                s1.Name = "line"
+            Next
+            Set st2 = ActiveLayer.CreateArtisticText(s.RightX + 3, s.BottomY, "单位：mm", , , "微软雅黑", TextBox1.value)
+            st2.text.Story.CharSpacing = 0 '字符间距
+            st2.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
+            st2.Name = "Text" ' 设置名
+         End If
+    Next
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 标注线长()
+    ActiveDocument.Unit = cdrMillimeter
+    Dim s As Shape, st1 As Shape
+    Set s = ActiveShape
+    If s Is Nothing Then Exit Sub
+    Optimization = True '优化启动
+    For Each s In ActiveSelection.Shapes
+        If s.Type <> cdrTextShape Then
+            X = s.LeftX
+            Y = s.BottomY
+            Set st1 = ActiveLayer.CreateArtisticText(X, Y, "线条长：" & round(s.DisplayCurve.Length, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrLeftAlignment)
+            st1.text.Story.CharSpacing = 0 '字符间距
+            st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
+            st1.Move 0, -st1.SizeHeight * 2
+            st1.Name = "Text" ' 设置名
+            s.CreateSelection
+        End If
+    Next
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 选中标注字号增加()
+    Dim s As Shape
+    Optimization = True '优化启动
+    If TextBox1.value > 0 Then
+        TextBox1.value = TextBox1.value + 1
+        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+            s.text.Story.size = s.text.Story.size + 1
+        Next
+    End If
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 选中标注字号减少()
+    Dim s As Shape
+    Optimization = True '优化启动
+    If TextBox1.value > 0 Then
+        TextBox1.value = TextBox1.value - 1
+        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+            s.text.Story.size = s.text.Story.size - 1
+        Next
+    End If
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 选中标注字号()
+    Dim s As Shape
+    Optimization = True '优化启动
+    If TextBox1.value > 0 Then
+        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+            s.text.Story.size = TextBox1.value
+        Next
+    End If
+    Optimization = False '优化关闭
+    ActiveWindow.Refresh '刷新文档窗口
+End Sub
+
+Private Sub 删除标注()
+    If ActiveSelection.Shapes.Count > 0 Then
+        ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ").Delete
+        ActiveSelection.Shapes.FindShapes(query:="@Name='line' ").Delete
+    Else
+        ActivePage.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ").Delete
+        ActivePage.Shapes.FindShapes(query:="@Name='line' ").Delete
+    End If
+End Sub
+

UI/Toolbar.bas

@@ -115,7 +115,7 @@ End With
   #End If
 End Sub
 
-Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   UI.Visible = False
   If Y > 1 And Y < 16 And UIL_Key Then
     UI.Picture = pic2
@@ -127,9 +127,13 @@ Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   ' Debug.Print X & " , " & Y
 End Sub
 
-Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     If Button Then
+<<<<<<< HEAD
+        mx = X: my = Y
+=======
         mx = x: my = Y
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
     End If
     
   With Me
@@ -138,15 +142,15 @@ Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
 
 End Sub
 
-Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+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.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
+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
@@ -155,20 +159,24 @@ Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVa
     LEFT_ALIGN_BT.Visible = False
     Exit Sub
   ElseIf Shift = fmCtrlMask Then
+<<<<<<< HEAD
+      mx = X: my = Y
+=======
       mx = x: my = Y
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
   Else
     Unload Me   ' Ctrl + 鼠标 关闭工具
   End If
 End Sub
 
-Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub LOGO_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.Left = Me.Left - mx + X
     Me.Top = Me.Top - my + Y
   End If
 End Sub
 
-Private Sub UI_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, pos_y As Variant
@@ -177,6 +185,34 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
 
   '// 按下Ctrl键，最优先处理工具功能
   If Shift = 2 Then
+<<<<<<< HEAD
+    If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 安全线，清除辅助线
+      Tools.guideangle CorelDRAW.ActiveSelectionRange, 3    ' 左键 3mm 出血
+      
+    ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// Adobe AI EPS INDD PDF和CorelDRAW 缩略图工具
+      AdobeThumbnail_Click
+      
+    ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 多物件拆分线段
+      Tools.Split_Segment
+      
+    ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 智能拆字
+      Tools.Take_Apart_Character
+      
+    ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 暂时空
+      
+    ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 暂时空
+      
+    ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 暂时空
+      
+    ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+=======
     If Abs(x - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
       '// 安全线，清除辅助线
       Tools.guideangle CorelDRAW.ActiveSelectionRange, 3    ' 左键 3mm 出血
@@ -203,6 +239,7 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
       '// 暂时空
       
     ElseIf Abs(x - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
       '// CTRL扩展工具栏
       Me.Height = 30 + 45
       
@@ -212,6 +249,40 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
 
   '// 鼠标右键 扩展键按钮优先  收缩工具栏  标记范围框  居中页面 尺寸取整数  单色黑中线标记 扩展工具栏  排列工具  扩展工具栏收缩
   If Button = 2 Then
+<<<<<<< HEAD
+    If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      Me.Width = 30: Me.Height = 30
+      UI.Visible = False: LOGO.Visible = True
+
+    ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      Tools.居中页面
+
+    ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      Tools.Mark_Range_Box
+
+    ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      Tools.尺寸取整
+    
+    ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      自动中线色阶条.Auto_ColorMark_K
+
+    '//分分合合把几个功能按键合并到一起，定义到右键上
+    ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      Tools.分分合合
+
+    ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      智能群组和查找.智能群组 API.Create_Tolerance
+
+    ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 右键扩展工具栏
+      Me.Height = 30 + 45
+      
+    ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 右键拆分线段
+      Tools.Split_Segment
+
+    ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+=======
     If Abs(x - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
       Me.Width = 30: Me.Height = 30
       UI.Visible = False: LOGO.Visible = True
@@ -244,11 +315,16 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
       Tools.Split_Segment
 
     ElseIf Abs(x - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
       '// 右键排列工具
       TOP_ALIGN_BT.Visible = True
       LEFT_ALIGN_BT.Visible = True
 
+<<<<<<< HEAD
+    ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+=======
     ElseIf Abs(x - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
       '// 右键扩展工具栏收缩
       Me.Height = 30
       
@@ -257,43 +333,43 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   End If
   
   '// 鼠标左键 单击按钮功能  按工具栏上图标正常功能
-  If Abs(x - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     裁切线.start
     
-  ElseIf Abs(x - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     剪贴板尺寸建立矩形.start
     
-  ElseIf Abs(x - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     裁切线.SelectLine_to_Cropline
     
-  ElseIf Abs(x - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     拼版裁切线.arrange
     
-  ElseIf Abs(x - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  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
+  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(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
+  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
+  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
+  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
+  ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     '// 扩展工具栏
     Me.Height = 30 + 45
     
     Speak_Msg "左右键有不同功能"
     
-  ElseIf Abs(x - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     If Me.Height > 30 Then
       Me.Height = 30
     Else
@@ -325,7 +401,11 @@ End Sub
 ' End Sub
 
 '''///  贪心商人和好玩工具等  ///'''
+<<<<<<< HEAD
+Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+=======
 Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
   If Button = 2 Then
     TSP.Nodes_To_TSP
   ElseIf Shift = fmCtrlMask Then
@@ -335,23 +415,23 @@ Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
   End If
 End Sub
 
-Private Sub Cdr_Nodes_BT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Cdr_Nodes_BT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   TSP_L1.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub START_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub START_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   TSP_L2.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub PATH_TO_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub PATH_TO_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   TSP_L3.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub TSP2DRAW_LINE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub TSP2DRAW_LINE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   TSP_L4.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     TSP.TSP_TO_DRAW_LINE
   ElseIf Shift = fmCtrlMask Then
@@ -428,7 +508,7 @@ Private Sub Tools_Icon_Click()
 End Sub
 
 '''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
-Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     MsgBox "鼠标右键，功能待定"
     Exit Sub
@@ -439,20 +519,21 @@ Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   End If
 End Sub
 
-Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    MsgBox "鼠标右键，功能待定"
-    Exit Sub
+    MsgBox "左键拆分线段，Ctrl合并线段"
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Split_Segment
+  Else
+    ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
+    Application.Refresh
   End If
   
-  If Button Then
-      Tools.Split_Segment
-  End If
-  Speak_Msg "拆分线段"
+  Speak_Msg "拆分线段，Ctrl合并线段"
 End Sub
 
 '''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换  ////'''
-Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim value As Integer
   If Button = 2 Then
     value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
@@ -466,7 +547,7 @@ Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As
 End Sub
 
 '''////  标记画框 支持容差  ////'''
-Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Mark_CreateRectangle True
   ElseIf Shift = fmCtrlMask Then
@@ -478,7 +559,7 @@ Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift
 End Sub
 
 '''////  一键拆开多行组合的文字字符  ////'''
-Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Batch_Combine
   ElseIf Shift = fmCtrlMask Then
@@ -491,7 +572,7 @@ Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 '''////  简单一刀切  ////'''
-Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Single_Line_Vertical
   ElseIf Shift = fmCtrlMask Then
@@ -504,7 +585,7 @@ Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Intege
 End Sub
 
 '''////  傻瓜火车排列  ////'''
-Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.傻瓜火车排列 3#
   ElseIf Shift = fmCtrlMask Then
@@ -515,7 +596,7 @@ Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
 End Sub
 
 '''////  傻瓜阶梯排列  ////'''
-Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.傻瓜阶梯排列 3#
   ElseIf Shift = fmCtrlMask Then
@@ -527,7 +608,7 @@ End Sub
 
 
 '''////  左键-多页合并一页工具   右键-批量多页居中 ////'''
-Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.批量多页居中
   ElseIf Shift = fmCtrlMask Then
@@ -553,7 +634,7 @@ Private Sub Quick_Color_Select_Click()
   Tools.quickColorSelect
 End Sub
 
-Private Sub Cut_Cake_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Cut_Cake_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.divideVertically
   ElseIf Shift = fmCtrlMask Then
@@ -564,13 +645,31 @@ Private Sub Cut_Cake_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
 End Sub
 
 '// 安全辅助线功能，三键控制，讨厌辅助线的也可以用来删除辅助线
-Private Sub Safe_Guideangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+Private Sub Safe_Guideangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.guideangle CorelDRAW.ActiveSelectionRange, 0#   ' 右键0距离贴紧
   ElseIf Shift = fmCtrlMask Then
     Tools.guideangle CorelDRAW.ActiveSelectionRange, 3    ' 左键 3mm 出血
   Else
     Tools.guideangle CorelDRAW.ActiveSelectionRange, -Set_Space_Width     ' Ctrl + 鼠标左键 自定义间隔
+<<<<<<< HEAD
+  End If
+End Sub
+
+
+Private Sub btn_makesizes_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Make_SIZE.Show 0   ' 右键
+  ElseIf Shift = fmCtrlMask Then
+    #If VBA7 Then
+      woodman.Show 0
+    #Else  ' X4 使用
+      Make_SIZE.Show 0
+    #End If
+  Else
+    Tools.Simple_Label_Numbers  ' Ctrl + 鼠标  批量简单数字标注
+=======
+>>>>>>> 0d7a93841c2ece54be5b9b16995c7a3e4d8c3296
   End If
 End Sub
 

UI/Woodman.bas

@@ -0,0 +1,325 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Woodman 
+   Caption         =   "Woodman标注尺寸节点"
+   ClientHeight    =   1935
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   3765
+   OleObjectBlob   =   "Woodman.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "woodman"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+    Set os = ActiveSelectionRange
+    Set ss = os.Shapes
+    uc = 0
+    For Each s In ss
+        s.SizeWidth = s.SizeHeight
+        uc = uc + 1
+    Next s
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+End Sub
+
+
+Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+    Set os = ActiveSelectionRange
+    Set ss = os.Shapes
+    uc = 0
+    For Each s In ss
+        s.SizeHeight = s.SizeWidth
+        uc = uc + 1
+    Next s
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+End Sub
+
+Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Dim os As ShapeRange
+    Dim s As Shape
+    Dim sr As ShapeRange
+    Set doc = ActiveDocument
+    
+'rasm.Dimension.TextShape.Text.Story.size = CLng(fnt)
+'rasm.Style.GetProperty("dimension").SetProperty "precision", 0
+'rasm.Style.GetProperty("dimension").SetProperty "units", 3
+    
+    doc.BeginCommandGroup "delete sizes"
+        Set sr = ActiveSelectionRange
+        sr.RemoveAll
+    If Shift = 4 Then
+        On Error Resume Next
+        Set os = ActiveSelectionRange
+        For Each s In os.Shapes
+            If s.Type = cdrLinearDimensionShape Then s.Delete
+        Next s
+        On Error GoTo 0
+    ElseIf Shift = 1 Then
+        Set os = ActiveSelectionRange
+        For Each s In os.Shapes
+            If s.Type = cdrLinearDimensionShape Then sr.Add s
+        Next s
+        sr.CreateSelection
+        On Error GoTo 0
+    ElseIf Shift = 2 Then
+        On Error Resume Next
+        Set os = ActiveSelectionRange
+        For Each s In os.Shapes
+            If s.Type = cdrLinearDimensionShape Then s.Delete
+        Next s
+        On Error GoTo 0
+    Else
+        make_sizes Shift
+    End If
+    doc.EndCommandGroup
+    Application.Refresh
+End Sub
+
+Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "up", Shift
+End Sub
+Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "dn", Shift
+End Sub
+Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "lf", Shift
+End Sub
+Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "ri", Shift
+End Sub
+
+Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "upb", Shift
+End Sub
+Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "dnb", Shift
+End Sub
+Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "lfb", Shift
+End Sub
+Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    make_sizes_sep "rib", Shift
+End Sub
+
+Sub make_sizes_sep(dr, Optional shft = 0)
+    Set doc = ActiveDocument
+    Dim s As Shape
+    Dim pts As New SnapPoint, pte As New SnapPoint
+    Dim os As ShapeRange
+    un = doc.Unit
+    doc.Unit = cdrMillimeter
+    doc.BeginCommandGroup "make sizes"
+    
+    Set os = ActiveSelectionRange
+        
+    If dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
+    If dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top"
+    
+    If os.Count > 0 Then
+        If os.Count > 1 And Len(dr) > 2 Then
+            For I = 1 To os.Shapes.Count - 1
+                Select Case dr
+                    Case "upb":
+                            Set pts = os.Shapes(I).SnapPoints.BBox(cdrTopRight)
+                            Set pte = os.Shapes(I + 1).SnapPoints.BBox(cdrTopLeft)
+                            ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+
+                    Case "dnb":
+                            Set pts = os.Shapes(I).SnapPoints.BBox(cdrBottomRight)
+                            Set pte = os.Shapes(I + 1).SnapPoints.BBox(cdrBottomLeft)
+                            ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering
+                    
+                    Case "lfb":
+                            Set pts = os.Shapes(I).SnapPoints.BBox(cdrBottomLeft)
+                            Set pte = os.Shapes(I + 1).SnapPoints.BBox(cdrTopLeft)
+                            ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+                    
+                    Case "rib":
+                            Set pts = os.Shapes(I).SnapPoints.BBox(cdrBottomRight)
+                            Set pte = os.Shapes(I + 1).SnapPoints.BBox(cdrTopRight)
+                            ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+                End Select
+                'ActiveDocument.ClearSelection
+            Next I
+        Else
+            If shft > 0 Then
+                Select Case dr
+                    Case "up":
+                            Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
+                            Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
+                            ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+                    
+                    Case "dn":
+                            Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft)
+                            Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
+                            ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering
+                    Case "lf":
+                            Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
+                            Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
+                            ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+                    Case "ri":
+                            Set pts = os.FirstShape.SnapPoints.BBox(cdrTopRight)
+                            Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
+                            ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+                End Select
+            Else
+                For Each s In os.Shapes
+                    Select Case dr
+                        Case "up":
+                                Set pts = s.SnapPoints.BBox(cdrTopLeft)
+                                Set pte = s.SnapPoints.BBox(cdrTopRight)
+                                ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering
+                        
+                        Case "dn":
+                                Set pts = s.SnapPoints.BBox(cdrBottomLeft)
+                                Set pte = s.SnapPoints.BBox(cdrBottomRight)
+                                ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.BottomY - s.SizeHeight / 10, cdrDimensionStyleEngineering
+                        Case "lf":
+                                Set pts = s.SnapPoints.BBox(cdrTopLeft)
+                                Set pte = s.SnapPoints.BBox(cdrBottomLeft)
+                                ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
+                        Case "ri":
+                                Set pts = s.SnapPoints.BBox(cdrTopRight)
+                                Set pte = s.SnapPoints.BBox(cdrBottomRight)
+                                ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
+                    End Select
+                Next s
+            End If
+        End If
+    End If
+    os.CreateSelection
+    doc.EndCommandGroup
+    doc.Unit = un
+End Sub
+
+Sub make_sizes(Optional shft = 0)
+    Set doc = ActiveDocument
+    Dim s As Shape
+    Dim pts As SnapPoint, pte As SnapPoint
+    Dim os As ShapeRange
+    un = doc.Unit
+    doc.Unit = cdrMillimeter
+    doc.BeginCommandGroup "make sizes"
+    Set os = ActiveSelectionRange
+    If os.Count > 0 Then
+    For Each s In os.Shapes
+        Set pts = s.SnapPoints.BBox(cdrTopLeft)
+        Set pte = s.SnapPoints.BBox(cdrTopRight)
+        Set ptle = s.SnapPoints.BBox(cdrBottomLeft)
+        If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
+        If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering
+    Next s
+    End If
+    doc.EndCommandGroup
+    doc.Unit = un
+End Sub
+
+Public Function make_selection(Optional mode = "fcolor", Optional sel = True, Optional OSS As ShapeRange = Nothing, Optional colr = Nothing) As ShapeRange
+    Dim s As Shape, lst As Shape
+    Dim sr As ShapeRange
+    'Dim os As ShapeRange
+    Set doc = ActiveDocument
+    doc.Unit = cdrTenthMicron
+    
+    If OSS Is Nothing Then
+        If toolspanel.num_list.value Or mode = "locked" Then
+            Set os = ActivePage
+        Else
+            Set os = ActiveSelectionRange
+        End If
+    Else
+        Set os = OSS
+    End If
+    Set sr = ActiveSelectionRange
+    sr.RemoveAll
+    If sel Then ActiveDocument.ClearSelection
+    Set lst = os.Shapes.First
+    For Each s In os.Shapes
+        Select Case mode
+            Case "ocolor": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 And s.Outline.Color.HexValue = colr.HexValue Then sr.Add s
+            Case "fcolor": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 And s.Fill.UniformColor.HexValue = colr.HexValue Then sr.Add s
+            Case "nofil": If s.Fill.Type = cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
+            Case "fil": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
+            Case "abr": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
+            Case "noabr": If s.Outline.Type = cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
+            Case "open": If Not s.DisplayCurve Is Nothing Then If Not s.DisplayCurve.Closed Then sr.Add s
+            Case "closed": If Not s.DisplayCurve Is Nothing Then If s.DisplayCurve.Closed Then sr.Add s
+            Case "single": If s.Shapes.Count = 0 Then sr.Add s
+            Case "dashed": If s.Outline.Style.DashCount > 0 Then sr.Add s
+            Case "groups": If s.Shapes.Count > 0 And s.Effect Is Nothing Then sr.Add s
+            Case "text": If s.Shapes.Count = 0 And s.Type = cdrTextShape Then sr.Add s
+            Case "notext": If s.Shapes.Count = 0 And s.Type <> cdrTextShape Then sr.Add s
+            Case "images": If s.Type = cdrBitmapShape Then sr.Add s
+            Case "locked": If s.Locked Then sr.Add s
+            Case "effects": If s.Effects.Count > 0 Or Not s.Effect Is Nothing Then sr.Add s
+            Case "noeffects": If s.Effects.Count = 0 And s.Effect Is Nothing Then sr.Add s
+            Case "bigger":
+                arelst = lst.SizeHeight * lst.SizeWidth
+                ares = s.SizeHeight * s.SizeWidth
+                If ares >= arelst Then
+                    are = one_shape_area(lst)
+                    If one_shape_area(s) >= are Then sr.Add s
+                End If
+            Case "smaller":
+                arelst = lst.SizeHeight * lst.SizeWidth
+                ares = s.SizeHeight * s.SizeWidth
+                If ares <= arelst Then
+                    are = one_shape_area(lst)
+                    If one_shape_area(s) <= are Then sr.Add s
+                End If
+            Case "last":
+                If lst.Fill.Type = cdrNoFill Then
+                    's.CreateSelection
+                    If s.Outline.Type <> cdrNoOutline Then If s.Outline.Color.HexValue = lst.Outline.Color.HexValue Then sr.Add s
+                Else
+                    If s.Fill.UniformColor.HexValue = lst.Fill.UniformColor.HexValue Then sr.Add s
+                End If
+        End Select
+    Next s
+    
+    If sr.Shapes.Count > 0 And sel Then sr.CreateSelection
+    Set make_selection = sr
+    
+    Application.Refresh
+    ActiveWindow.Activate
+End Function
+
+Public Function get_events(btn As String, Optional shft = 0, Optional click = 1)
+    out = "ok"
+    get_events = out
+End Function
+
+Private Sub btn_join_nodes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
+    Application.Refresh
+End Sub
+
+Private Sub btn_nodes_reduce_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    On Error GoTo ErrorHandler
+    Set doc = ActiveDocument
+    Dim s As Shape
+    ps = Array(1)
+    doc.Unit = cdrTenthMicron
+    Set os = ActivePage.Shapes
+    If os.Count > 0 Then
+        doc.BeginCommandGroup "reduce nodes"
+        For Each s In os
+            s.ConvertToCurves
+            If Not s.DisplayCurve Is Nothing Then
+                s.Curve.AutoReduceNodes 50
+            End If
+        Next s
+        doc.EndCommandGroup
+    End If
+    Application.Refresh
+ErrorHandler:
+  MsgBox "s.Curve.AutoReduceNodes 只有高版本才支持本API"
+End Sub
+
+

module/Tools.bas

@@ -7,9 +7,9 @@ Public Function 分分合合()
   拼版裁切线.Cut_lines
 
   ' 记忆选择范围
-  Dim x As Double, Y As Double, w As Double, h As Double
-  ActiveSelectionRange.GetBoundingBox x, Y, w, h
-  Set s = ActivePage.SelectShapesFromRectangle(x, Y, w, h, True)
+  Dim X As Double, Y As Double, w As Double, h As Double
+  ActiveSelectionRange.GetBoundingBox X, Y, w, h
+  Set s = ActivePage.SelectShapesFromRectangle(X, Y, w, h, True)
   
   自动中线色阶条.Auto_ColorMark
 
@@ -224,7 +224,7 @@ Public Function QRCode_replace()
   image_path = API.GetClipBoardString
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim x As Double, Y As Double
+  Dim X As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -236,11 +236,11 @@ Public Function QRCode_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition x, Y
-    sc.SetPosition x, Y
+    sh.GetPosition X, Y
+    sc.SetPosition X, Y
     
-    sh.GetSize x, Y
-    sc.SetSize x, Y
+    sh.GetSize X, Y
+    sc.SetSize X, Y
     sh.Delete
     
   Next sh
@@ -339,24 +339,24 @@ End Function
 
 Private Function mark_shape_expand(sh As Shape, tr As Double)
     Dim s As Shape
-    Dim x As Double, Y As Double, w As Double, h As Double, r As Double
-    sh.GetBoundingBox x, Y, w, h
-    x = x - tr: Y = Y - tr:   w = w + 2 * tr: h = h + 2 * tr
+    Dim X As Double, Y As Double, w As Double, h As Double, r As Double
+    sh.GetBoundingBox X, Y, w, h
+    X = X - tr: Y = Y - tr:   w = w + 2 * tr: h = h + 2 * tr
     
     r = Max(w, h) / Min(w, h) / 30 * Math.Sqr(w * h)
     If w < h Then
-      Set s = ActiveLayer.CreateRectangle2(x - r, Y, w + 2 * r, h)
+      Set s = ActiveLayer.CreateRectangle2(X - r, Y, w + 2 * r, h)
     Else
-      Set s = ActiveLayer.CreateRectangle2(x, Y - r, w, h + 2 * r)
+      Set s = ActiveLayer.CreateRectangle2(X, Y - r, w, h + 2 * r)
     End If
     s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
 Private Function mark_shape(sh As Shape)
   Dim s As Shape
-  Dim x As Double, Y As Double, w As Double, h As Double
-  sh.GetBoundingBox x, Y, w, h, True
-  Set s = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  Dim X As Double, Y As Double, w As Double, h As Double
+  sh.GetBoundingBox X, Y, w, h, True
+  Set s = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
@@ -410,9 +410,9 @@ Public Function Take_Apart_Character()
   Dim tr As Double
   
   ' 记忆选择范围
-  Dim x As Double, Y As Double, w As Double, h As Double
-  ssr.GetBoundingBox x, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  Dim X As Double, Y As Double, w As Double, h As Double
+  ssr.GetBoundingBox X, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   
   ' 解散群组，先组合，再散开
   Set s = ssr.UngroupAllEx.Combine
@@ -429,7 +429,7 @@ Public Function Take_Apart_Character()
     mark_shape_expand sh, tr
   Next sh
   
-  Set ssr = ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(0, 255, 0))")
+  Set ssr = ActivePage.Shapes.FindShapes(query:="@colors.find(RGB(0, 255, 0))")
   ActiveDocument.ClearSelection
   ssr.AddToSelection
   
@@ -484,10 +484,10 @@ Public Function Single_Line()
   End If
     
   ' 记忆选择范围
-  Dim x As Double, Y As Double, w As Double, h As Double
+  Dim X As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox x, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  ssr.GetBoundingBox X, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -547,10 +547,10 @@ Public Function Single_Line_Vertical()
   End If
     
   ' 记忆选择范围
-  Dim x As Double, Y As Double, w As Double, h As Double
+  Dim X As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox x, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  ssr.GetBoundingBox X, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -606,10 +606,10 @@ Public Function Single_Line_LastNode()
   End If
     
   ' 记忆选择范围
-  Dim x As Double, Y As Double, w As Double, h As Double
+  Dim X As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox x, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  ssr.GetBoundingBox X, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -650,17 +650,17 @@ Public Function Mark_Range_Box()
   Dim s1 As Shape, ssr As ShapeRange
   
   Set ssr = ActiveSelectionRange
-  Dim x As Double, Y As Double, w As Double, h As Double
+  Dim X As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox x, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
+  ssr.GetBoundingBox X, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0) ' RGB 绿
 End Function
 
 
 '''//// 快速颜色选择 ////'''
 Function quickColorSelect()
-    Dim x As Double, Y As Double
+    Dim X As Double, Y As Double
     Dim s As Shape, s1 As Shape
     Dim sr As ShapeRange, sr2 As ShapeRange
     Dim Shift As Long, bClick As Boolean
@@ -668,14 +668,14 @@ Function quickColorSelect()
 
     EventsEnabled = False
     
-    Set sr = ActivePage.Shapes.FindShapes(Query:="@fill.type = 'uniform'")
+    Set sr = ActivePage.Shapes.FindShapes(query:="@fill.type = 'uniform'")
     ActiveDocument.ClearSelection
     bClick = False
     While Not bClick
     On Error Resume Next
-        bClick = ActiveDocument.GetUserClick(x, Y, Shift, 10, False, cdrCursorPickNone)
+        bClick = ActiveDocument.GetUserClick(X, Y, Shift, 10, False, cdrCursorPickNone)
         If Not bClick Then
-            Set s = ActivePage.SelectShapesAtPoint(x, Y, False)
+            Set s = ActivePage.SelectShapesAtPoint(X, Y, False)
             Set s = s.Shapes.Last
             c2.CopyAssign s.Fill.UniformColor
             Set sr2 = New ShapeRange
@@ -732,7 +732,7 @@ End Function
 Private Function cutInHalf(Optional method As Integer)
     Dim s As Shape, rect As Shape, rect2 As Shape
     Dim trimmed1 As Shape, trimmed2 As Shape
-    Dim x As Double, Y As Double, w As Double, h As Double
+    Dim X As Double, Y As Double, w As Double, h As Double
     Dim vBool As Boolean
     Dim leeway As Double
     Dim sr As ShapeRange, sr2 As New ShapeRange
@@ -745,15 +745,15 @@ Private Function cutInHalf(Optional method As Integer)
     Set sr = ActiveSelectionRange
     ActiveDocument.BeginCommandGroup "Cut in half"
     For Each s In sr
-        s.GetBoundingBox x, Y, w, h
+        s.GetBoundingBox X, Y, w, h
         
         If (vBool) Then
             'vertical slice
-            Set rect = ActiveLayer.CreateRectangle2(x - leeway, Y - leeway, (w / 2) + leeway, h + (leeway * 2))
-            Set rect2 = ActiveLayer.CreateRectangle2(x + (w / 2), Y - leeway, (w / 2) + leeway, h + (leeway * 2))
+            Set rect = ActiveLayer.CreateRectangle2(X - leeway, Y - leeway, (w / 2) + leeway, h + (leeway * 2))
+            Set rect2 = ActiveLayer.CreateRectangle2(X + (w / 2), Y - leeway, (w / 2) + leeway, h + (leeway * 2))
         Else
-            Set rect = ActiveLayer.CreateRectangle2(x - leeway, Y - leeway, w + (leeway * 2), (h / 2) + leeway)
-            Set rect2 = ActiveLayer.CreateRectangle2(x - leeway, Y + (h / 2), w + (leeway * 2), (h / 2) + leeway)
+            Set rect = ActiveLayer.CreateRectangle2(X - leeway, Y - leeway, w + (leeway * 2), (h / 2) + leeway)
+            Set rect2 = ActiveLayer.CreateRectangle2(X - leeway, Y + (h / 2), w + (leeway * 2), (h / 2) + leeway)
         End If
         
         Set trimmed1 = rect.Intersect(s, True, True)
@@ -843,3 +843,17 @@ Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
   
 End Function
 
+'// 标注尺寸 批量简单标注数字
+Public Function Simple_Label_Numbers()
+  ActiveDocument.Unit = cdrMillimeter
+  Set sr = ActiveSelectionRange
+  
+  For Each s In sr.Shapes
+    X = s.CenterX: Y = s.TopY
+    sw = s.SizeWidth: sh = s.SizeHeight
+          
+    text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
+    Set s = ActiveLayer.CreateArtisticText(0, 0, text)
+    s.CenterX = X: s.BottomY = Y + 5
+  Next
+End Function