Update CorelDRAW 物件排列拼版简单代码

module/Arrange.bas

@@ -1,38 +1,41 @@
 Attribute VB_Name = "Arrange"
-'// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
-'// Attribute VB_Name = "物件排列拼版"   Arrange  2023.6.11
+'// Attribute VB_Name = "物件排列拼版"   Arrange  2023.12.20
 
 '// CorelDRAW 物件排列拼版简单代码
 Public Function Arrange()
   On Error GoTo ErrorHandler
+#If VBA7 Then
   API.BeginOpt
+#Else
+  '// CorelDRAW X4 刷新缓冲区有问题
   ActiveDocument.Unit = cdrMillimeter
+#End If
   row = 3     ' 拼版 3 x 4
   List = 4
   sp = 0       '间隔 0mm
 
-  Dim Str, arr, n
-  Str = API.GetClipBoardString
+  Dim str, arr, n
+  str = API.GetClipBoardString
 
   ' 替换 mm x * 换行 TAB 为空格
-  Str = VBA.Replace(Str, "mm", " ")
-  Str = VBA.Replace(Str, "x", " ")
-  Str = VBA.Replace(Str, "X", " ")
-  Str = VBA.Replace(Str, "*", " ")
+  str = VBA.Replace(str, "mm", " ")
+  str = VBA.Replace(str, "x", " ")
+  str = VBA.Replace(str, "X", " ")
+  str = VBA.Replace(str, "*", " ")
 
   '// 换行转空格 多个空格换成一个空格
-  Str = API.Newline_to_Space(Str)
+  str = API.Newline_to_Space(str)
   
-  arr = Split(Str)
+  arr = Split(str)
 
   Dim s1 As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   
   If 0 = ActiveSelectionRange.Count Then
-    X = Val(arr(0)):    Y = Val(arr(1))
-    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
+    x = Val(arr(0)):    Y = Val(arr(1))
+    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
 
     If UBound(arr) > 2 Then
@@ -45,7 +48,7 @@ Public Function Arrange()
     End If
      
     '// 建立矩形 Width  x Height 单位 mm
-    Set s1 = ActiveLayer.CreateRectangle(0, 0, X, Y)
+    Set s1 = ActiveLayer.CreateRectangle(0, 0, x, Y)
     
     '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
     s1.Fill.ApplyNoFill
@@ -53,23 +56,32 @@ Public Function Arrange()
       ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
 
   '// 如果当前选择物件，按当前物件拼版
-  ElseIf 1 = ActiveSelectionRange.Count Then
+  ElseIf 0 < ActiveSelectionRange.Count Then
     Set s1 = ActiveSelection
-    X = s1.SizeWidth:    Y = s1.SizeHeight
-    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
+    x = s1.SizeWidth:    Y = s1.SizeHeight
+    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
   End If
   
-  sw = X:  sh = Y
+  sw = x:  sh = Y
 
   '// StepAndRepeat 方法在范围内创建多个形状副本
-  Dim dup1 As ShapeRange
-  Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
-  Dim dup2 As ShapeRange
-  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
-       
+  Dim dup1 As ShapeRange, dup2 As ShapeRange
+  If row > 1 Then
+    Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
+    If List > 1 Then Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
+  End If
+  If List > 1 And row < 2 Then Set dup1 = s1.StepAndRepeat(List - 1, 0#, (sh + sp))
+  
 ErrorHandler:
   API.EndOpt
 End Function
 
 
+  '*****************   之前旧的代码 不能处理 row 和 list 等于1 的     **********************
+'  Dim dup1 As ShapeRange
+'  Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
+'  Dim dup2 As ShapeRange
+'  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
+
+