蘭雅CorelVBA工具 2024.5.1 测试版 永久免费开源开放

README.md

@@ -1,6 +1,9 @@
 ### [捐赠 蘭雅CorelVBA工具 开源软件](https://github.com/hongwenjun/corelvba/blob/main/donate.md)
 - [![](https://raw.githubusercontent.com/hongwenjun/vps_setup/master/img/youtube.png)频道](https://www.youtube.com/sRGB18/videos)   www.youtube.com/sRGB18   [![](https://raw.githubusercontent.com/hongwenjun/vps_setup/master/img/paypal.png)赞赏支持!](https://paypal.me/sRGB18)  https://paypal.me/sRGB18
 
+## 蘭雅CorelVBA工具 2024.5.1 测试版 永久免费开源开放
+
+![](https://lyvba.com/wp-content/uploads/2024/04/lyvba2024.webp)
 
 ## *LYVBA_MakeSizes.gms* :  Streamlining GMS files that only keep batch size features
 
@@ -8,7 +11,6 @@
 ![Batch_Dimension](https://raw.githubusercontent.com/hongwenjun/img/master/VBA/Batch_Dimension.webp)
 
 
-
 # [CorelDRAW VBA](https://262235.xyz/index.php/tag/vba/)
 ![](https://262235.xyz/usr/uploads/2022/03/525753621.webp)
 
@@ -42,6 +44,39 @@
 ## 蘭雅CorelVBA工具中秋版 修复更新和添加的主要功能
 
 ```
+* 15a5e2c 蘭雅CorelDRAW插件 2024.5.1国际劳动节版
+* aa46161 批量多页居中-遍历批量物件，放置物件到页面  @杰开 修改
+* 1d915f7 CQL 曲线长度用法示例笔记
+* 2b5970b 捐赠网友将送商业版注册激活码一份
+* 261b65b 2023.12.29 庆祝蘭雅CorelVBA工具捐赠和收益总额达到5000元
+* e6ba429 Update CorelDRAW 物件排列拼版简单代码
+* 9852596 Update 智能群组 SmartGroup
+* 695af7a 容器选择代码更新
+* 89d3960 容器模块代码
+* a0fe673 zerobase.gms 源码分享
+* 2937724 智能群组和批量居中合并
+* 7b5322b 智能群组和批量居中分离的
+* 117525b 优化走刀算法，增加安装包iss脚本
+* ffb2b28 自动裁切线第一版算法
+* fafe547 2022.12.29 批量导图等多个功能合并主线
+* 7cad4ad 更新尺寸标注统一长宽节点合并
+* 0d7a938 蘭雅CorelVBA_五彩斑斓的黑更新_12.16
+* f7863ba 2022.12.13 庆祝蘭雅CorelVBA工具捐赠和收益总额达到3000元
+* 92a90b0 2022.12.09更新,增加安全辅助线和批量多页居中功能
+* 93670b7 贪心商人TSP升级
+* e1c342c 一刀切升级，Python工具源码加入
+* 2a8eb82 UI独立图片，工具栏三个皮肤，鼠标悬停五彩斑斓的黑
+* 8215267 蘭雅CorelVBA工具 UI独立图片 添加语音功能提示
+* 1457811 蘭雅CorelVBA工具-中秋版 更换UI图
+* 0f35182 简单一刀切_识别群组由群友宏瑞广告赞助发行
+* b2eb2c4 一键智能群组--功能由群友半缘君赞助发行
+* ae14f4f 一键智能拆字功能更新
+* 71bc9a1 添加功能: Adobe_Illustrator复制粘贴互转  标记画框  一键智能拆字 拆分线段
+* 32649bf 修改颜色条注册表控制
+* c568449 2022-08更新添加设置保存注册表
+* 17cb37e 蘭雅CorelVBA工具箱 0520完整版源码更新
+* cdf7194 Update CorelDRAW_VBA编程手册_学习笔记.bas
+* fa187b5 蘭雅CorelVBA工具箱工具栏UI功能导图
 * 2022.12.23 更新尺寸标注统一长宽节点合并
 * 92a90b0 2022.12.09更新,增加安全辅助线和批量多页居中功能
 * 93670b7 贪心商人TSP升级

module/ClipbRectangle.bas

@@ -20,20 +20,20 @@ Public Function Build_Rectangle()
   O_O.Y = ost.BottomY - 50    '// 选择物件 下移动 50mm
   
   '// 建立矩形 Width  x Height 单位 mm
-  Dim Str, arr, n
-  Str = API.GetClipBoardString
+  Dim str, arr, n
+  str = API.GetClipBoardString
   
   '// 替换 mm x * 换行 TAB 为空格
-  Str = VBA.Replace(Str, "m", " ")
-  Str = VBA.Replace(Str, "x", " ")
-  Str = VBA.Replace(Str, "X", " ")
-  Str = VBA.Replace(Str, "*", " ")
-  Str = VBA.Replace(Str, vbNewLine, " ")
+  str = VBA.Replace(str, "m", " ")
+  str = VBA.Replace(str, "x", " ")
+  str = VBA.Replace(str, "X", " ")
+  str = VBA.Replace(str, "*", " ")
+  str = VBA.Replace(str, vbNewLine, " ")
   
-  Do While InStr(Str, "  ")     '// 多个空格换成一个空格
-      Str = VBA.Replace(Str, "  ", " ")
+  Do While InStr(str, "  ")     '// 多个空格换成一个空格
+      str = VBA.Replace(str, "  ", " ")
   Loop
-  arr = Split(Str)
+  arr = Split(str)
   
   API.BeginOpt
   Dim X As Double
@@ -51,14 +51,14 @@ Public Function Build_Rectangle()
 End Function
 
 '// 建立矩形 Width  x Height 单位 mm
-Private Function Rectangle(Width As Double, Height As Double)
+Private Function Rectangle(width As Double, Height As Double)
   ActiveDocument.Unit = cdrMillimeter
   Dim size As Shape
   Dim d As Document
   Dim s1 As Shape
 
   '// 建立矩形 Width  x Height 单位 mm
-  Set s1 = ActiveLayer.CreateRectangle(O_O.X, O_O.Y, O_O.X + Width, O_O.Y - Height)
+  Set s1 = ActiveLayer.CreateRectangle(O_O.X, O_O.Y, O_O.X + width, O_O.Y - Height)
   
   '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
   s1.Fill.ApplyNoFill
@@ -67,14 +67,14 @@ Private Function Rectangle(Width As Double, Height As Double)
   sw = s1.SizeWidth
   sh = s1.SizeHeight
 
-  text = Trim(Str(sw)) + "x" + Trim(Str(sh)) + "mm"
+  text = Trim(str(sw)) + "x" + Trim(str(sh)) + "mm"
   Set d = ActiveDocument
   Set size = d.ActiveLayer.CreateArtisticText(O_O.X + sw / 2 - 25, O_O.Y + 10, text, Font:="Tahoma")  '// O_O.y + 10  标注尺寸上移 10mm
   size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 End Function
 
 '// 测试矩形变形
-Private Function setRectangle(Width As Double, Height As Double)
+Private Function setRectangle(width As Double, Height As Double)
   Dim s1 As Shape
   Set s1 = ActiveSelection
   ActiveDocument.Unit = cdrMillimeter
@@ -98,7 +98,7 @@ Public Function get_all_size()
   Set shs = ActiveSelection.Shapes
   Dim s As String
   For Each sh In shs
-    size = Trim(Str(Int(sh.SizeWidth + 0.5))) + "x" + Trim(Str(Int(sh.SizeHeight + 0.5))) + "mm"
+    size = Trim(str(Int(sh.SizeWidth + 0.5))) + "x" + Trim(str(Int(sh.SizeHeight + 0.5))) + "mm"
     f.WriteLine (size)
     s = s + size + vbNewLine
   Next sh

module/CutLines.bas

@@ -18,17 +18,17 @@ Public Function Batch_CutLines()
 
   For Each s1 In OrigSelection
     lx = s1.LeftX:      rx = s1.RightX
-    By = s1.BottomY:    ty = s1.TopY
+    by = s1.BottomY:    ty = s1.TopY
     cx = s1.CenterX:    cy = s1.CenterY
     sw = s1.SizeWidth:  sh = s1.SizeHeight
     
     '//  添加裁切线，分别左下-右下-左上-右上
     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))
@@ -64,7 +64,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
 
   For Each s1 In OrigSelection
     lx = s1.LeftX:      rx = s1.RightX
-    By = s1.BottomY:    ty = s1.TopY
+    by = s1.BottomY:    ty = s1.TopY
     
     '//  添加使用 左-上 标注尺寸标记线
     Dim s2, s6, s7, s8, s9 As Shape
@@ -74,7 +74,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
       Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + Line_len))
       sr.Add s7: sr.Add s9
     Else
-      Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, By, lx - (Bleed + Line_len), By)
+      Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + Line_len), by)
       Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + Line_len), ty)
       sr.Add s2: sr.Add s6
     End If
@@ -91,7 +91,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
   
   '// 页面边缘对齐
   For Each s In sr
-    s.Name = "DMKLine"
+    s.name = "DMKLine"
     If mark = cdrAlignTop Then
       s.TopY = py + Line_len + Bleed
     Else
@@ -124,9 +124,9 @@ Public Function RemoveDuplicates(sr As ShapeRange)
   cnt = 1
   
   #If VBA7 Then
-     sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+    sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
   #Else
-    ' X4 不支持 ShapeRange.sort
+    Set sr = X4_Sort_ShapeRange(sr, topWt_left)
   #End If
 
   For Each s In sr
@@ -232,14 +232,14 @@ Public Function Draw_Lines()
   For Each Target In OrigSelection
     Set s1 = Target
     lx = s1.LeftX:   rx = s1.RightX
-    By = s1.BottomY: ty = s1.TopY
+    by = s1.BottomY: ty = s1.TopY
     cx = s1.CenterX: cy = s1.CenterY
     
     '// 范围边界物件判断
-    If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - By) _
+    If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
       < radius Or Abs(set_ty - ty) < radius Then
       
-      arr = Array(lx, By, rx, By, lx, ty, rx, ty)  '// 物件左下-右下-左上-右上 四个顶点坐标数组
+      arr = Array(lx, by, rx, by, lx, ty, rx, ty)  '// 物件左下-右下-左上-右上 四个顶点坐标数组
       For i = 0 To 3
         dot.X = arr(2 * i)
         dot.Y = arr(2 * i + 1)

module/TSP.bas

@@ -1,3 +1,4 @@
+Attribute VB_Name = "TSP"
 '// 导出节点信息到数据文件
 Public Function CDR_TO_TSP()
   API.BeginOpt
@@ -45,8 +46,8 @@ Public Function Nodes_To_TSP()
   
   TSP = nr.Count & " " & 0 & vbNewLine
   For Each n In nr
-      X = round(n.PositionX, 3) & " "
-      Y = round(n.PositionY, 3) & vbNewLine
+      X = Round(n.PositionX, 3) & " "
+      Y = Round(n.PositionY, 3) & vbNewLine
       TSP = TSP & X & Y
   Next n
   
@@ -75,19 +76,19 @@ Public Function TSP_TO_DRAW_LINE()
 
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.OpenTextFile("C:\TSP\TSP.txt", 1, False)
-  Dim Str, arr, n
-  Str = f.ReadAll()
+  Dim str, arr, n
+  str = f.ReadAll()
   
-  Str = API.Newline_to_Space(Str)
-  arr = Split(Str)
+  str = API.Newline_to_Space(str)
+  arr = Split(str)
   total = Val(arr(0))
   
   ReDim ce(total) As CurveElement
   Dim crv As Curve
   
   ce(0).ElementType = cdrElementStart
-  ce(0).PositionX = Val(arr(2)) - 3    '// 线条起始坐标，偏移3mm方向指示
-  ce(0).PositionY = Val(arr(3)) - 3
+  ce(0).PositionX = Val(arr(2)) ' - 3    '// 线条起始坐标，偏移3mm方向指示
+  ce(0).PositionY = Val(arr(3)) ' - 3
   
   Dim X As Double
   Dim Y As Double
@@ -122,13 +123,13 @@ Public Function TSP_TO_DRAW_LINES()
   
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
-  Dim Str, arr, n
+  Dim str, arr, n
   Dim line As Shape
-  Str = f.ReadAll()
+  str = f.ReadAll()
   
-  Str = API.Newline_to_Space(Str)
+  str = API.Newline_to_Space(str)
   
-  arr = Split(Str)
+  arr = Split(str)
   For n = 2 To UBound(arr) - 1 Step 4
     X = Val(arr(n))
     Y = Val(arr(n + 1))
@@ -206,5 +207,5 @@ Private Function make_dots(X As Double, Y As Double)
   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#
+  s.Outline.width = 0#
 End Function

module/Tools.bas

@@ -1,3 +1,4 @@
+Attribute VB_Name = "Tools"
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
@@ -13,7 +14,8 @@ Public Function Simple_Train_Arrangement(Space_Width As Double)
 '  ssr.sort " @shape1.top>@shape2.top"
   ssr.Sort " @shape1.left<@shape2.left"
 #Else
-' X4 不支持 ShapeRange.sort
+' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
+  Set ssr = X4_Sort_ShapeRange(ssr, stlx)
 #End If
 
   ActiveDocument.ReferencePoint = cdrTopLeft
@@ -38,11 +40,12 @@ Public Function Simple_Ladder_Arrangement(Space_Width As Double)
 
 #If VBA7 Then
   ssr.Sort " @shape1.top>@shape2.top"
-'  ssr.sort " @shape1.left<@shape2.left"
 #Else
-' X4 不支持 ShapeRange.sort
+' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
+  Set ssr = X4_Sort_ShapeRange(ssr, stty).ReverseRange
 #End If
 
+
   ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
     If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
@@ -706,47 +709,42 @@ Private Function cutInHalf(Optional method As Integer)
 End Function
 
 
-'// 批量多页居中-遍历批量物件，放置物件到页面  '杰开修改
+'// 批量多页居中-遍历批量物件，放置物件到页面
 Public Function Batch_Align_Page_Center()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   
   Set sr = ActiveSelectionRange
-'  sr.MoveToLayer ActiveDocument.DesktopLayer
   total = sr.Count
 
   '// 建立多页面
   Set doc = ActiveDocument
   doc.AddPages (total - 1)
 
-
 #If VBA7 Then
   sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
 #Else
 ' X4 不支持 ShapeRange.sort
+  Set sr = X4_Sort_ShapeRange(ssr, topWt_left).ReverseRange
 #End If
 
-
   Dim sh As Shape
-'  MoveToLayer ActivePage.DesktopLayer
-  '// 遍历批量物件，放置物件到页面  InsertPagesEx   ActivePage
+  '// 遍历批量物件，放置物件到页面
   For i = 1 To sr.Count
     doc.Pages(i).Activate
     Set sh = sr.Shapes(i)
     ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  
+    sh.MoveToLayer ActivePage.ActiveLayer
    '// 物件居中页面
-    #If VBA7 Then
-      ActiveDocument.ClearSelection
-      sh.AddToSelection
-      sh.MoveToLayer ActivePage.ActiveLayer
-      
-      ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
-    #Else
-      sh.MoveToLayer doc.Pages(i).ActiveLayer
-      sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
-    #End If
+#If VBA7 Then
+    ActiveDocument.ClearSelection
+    sh.AddToSelection
+    ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+    sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
 
   Next i
 ErrorHandler:
@@ -1080,12 +1078,12 @@ Public Function Mirror_ByGuide()
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
-  If nr.Count = 2 Then
+  If nr.Count >= 2 Then
     byshape = False
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
-    sr.Remove sr.Count
+    sr.remove sr.Count
     
     ang = 90 - a    '// 镜像的旋转角度
     For Each s In sr
@@ -1129,11 +1127,11 @@ Public Function Count_byArea(Space_Width As Double)
 ' X4 不支持 ShapeRange.sort
 #End If
 
-  Dim Str As String, size As String
+  Dim str As String, size As String
   For Each sh In ssr
     size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
     sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
-    Str = Str & size & vbNewLine
+    str = str & size & vbNewLine
   Next sh
 
   ActiveDocument.ReferencePoint = cdrTopLeft
@@ -1147,26 +1145,26 @@ Public Function Count_byArea(Space_Width As Double)
 '  Set f = fs.CreateTextFile("D:\size.txt", True)
 '  f.WriteLine str: f.Close
 
-  Str = Subtotals(Str)
-  Debug.Print Str
+  str = Subtotals(str)
+  Debug.Print str
 
   Dim s1 As Shape
 ' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
   X = ssr.FirstShape.LeftX - 100
   Y = ssr.FirstShape.TopY
-  Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, Str, Font:="华文中宋")
+  Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, str, Font:="华文中宋")
 
   API.EndOpt
 End Function
  
 '// 实现Excel里分类汇总功能
-Private Function Subtotals(Str As String) As String
+Private Function Subtotals(str As String) As String
   Dim a, b, d, arr
-  Str = VBA.Replace(Str, vbNewLine, " ")
-  Do While InStr(Str, "  ")
-      Str = VBA.Replace(Str, "  ", " ")
+  str = VBA.Replace(str, vbNewLine, " ")
+  Do While InStr(str, "  ")
+      str = VBA.Replace(str, "  ", " ")
   Loop
-  arr = Split(Str)
+  arr = Split(str)
 
   Set d = CreateObject("Scripting.dictionary")
 
@@ -1178,13 +1176,13 @@ Private Function Subtotals(Str As String) As String
     End If
   Next
 
-  Str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
+  str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
 
   a = d.keys: b = d.items
   For i = 0 To d.Count - 1
     ' Debug.Print a(i), b(i)
-    Str = Str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
+    str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
   Next
 
-  Subtotals = Str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
+  Subtotals = str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
 End Function