zerobase.gms 源码分享

zerobase/ArrangeForm.frm

@@ -0,0 +1,88 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm 
+   Caption         =   "蘭雅sRGB 手动拼版 │ 嘉盟赞助"
+   ClientHeight    =   2475
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   4650
+   OleObjectBlob   =   "ArrangeForm.frx":0000
+   ShowModal       =   0   'False
+   StartUpPosition =   2  '屏幕中心
+   WhatsThisButton =   -1  'True
+   WhatsThisHelp   =   -1  'True
+End
+Attribute VB_Name = "ArrangeForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Private Sub CommandButton1_Click()
+  On Error GoTo ErrorHandler
+  ActiveDocument.Unit = cdrMillimeter
+  Dim ls As Integer, hs As Integer
+  Dim lj As Double, hj As Double
+  Dim matrix As Variant
+  Dim s As ShapeRange
+  
+  ls = Val(TextBox1.text)
+  hs = Val(TextBox2.text)
+  lj = Val(TextBox3.text)
+  hj = Val(TextBox4.text)
+  matrix = Array(ls, hs, lj, hj)
+  
+  Set s = ActiveSelectionRange
+
+  If ls * hs = 0 Then Exit Sub
+  If ls = 1 Or hs = 1 Then
+    arrange_Clone_one matrix, s
+    Exit Sub
+  End If
+  
+  '// 代码运行时关闭窗口刷新
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  '// 拼版矩阵
+  arrange_Clone matrix, s
+
+  ActiveDocument.EndCommandGroup
+  Unload Me
+  
+  '// 代码操作结束恢复窗口刷新
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  Exit Sub
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Sub
+
+'// 拼版矩阵  matrix = Array(ls,hs,lj,hj)
+Private Function arrange_Clone(matrix As Variant, s As ShapeRange)
+  ls = matrix(0): hs = matrix(1)
+  lj = matrix(2): hj = matrix(3)
+  x = s.SizeWidth: y = s.SizeHeight
+  Set s1 = s.Clone
+  '// StepAndRepeat 方法在范围内创建多个形状副本
+  Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
+  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+  s1.Delete
+End Function
+
+Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
+  ls = matrix(0): hs = matrix(1)
+  lj = matrix(2): hj = matrix(3)
+  x = s.SizeWidth: y = s.SizeHeight
+  Set s1 = s.Clone
+  '// StepAndRepeat 方法在范围内创建多个形状副本
+  If ls > 1 Then
+    Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
+  Else
+    Set dup1 = s1
+  End If
+  If hs > 1 Then
+    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+  End If
+  s1.Delete
+End Function
+

zerobase/AutoCutLines.bas

@@ -0,0 +1,118 @@
+Attribute VB_Name = "AutoCutLines"
+#If VBA7 Then
+  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
+#Else
+  Private Declare Sub Sleep Lib "kernel32" (ByValdwMilliseconds As Long)
+#End If
+
+Public Sub AutoCutLines()
+  Nodes_TO_TSP
+  START_Cut_Line_Algorithm 3#
+  
+  '延时500毫秒，如果电脑够快，可以调整到100ms
+  Sleep 500
+  TSP_TO_DRAW_LINES
+End Sub
+
+Private Function Nodes_TO_TSP()
+    On Error GoTo ErrorHandler
+    ActiveDocument.BeginCommandGroup: Application.Optimization = True
+    ActiveDocument.Unit = cdrMillimeter
+
+    Set fs = CreateObject("Scripting.FileSystemObject")
+    Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+
+    Dim s As Shape, ssr As ShapeRange
+    Set ssr = ActiveSelectionRange
+
+    Dim TSP As String
+    TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
+
+    For Each s In ssr
+        lx = s.LeftX:   rx = s.RightX
+        By = s.BottomY: ty = s.TopY
+        TSP = TSP & lx & " " & By & vbNewLine
+        TSP = TSP & lx & " " & ty & vbNewLine
+        TSP = TSP & rx & " " & By & vbNewLine
+        TSP = TSP & rx & " " & ty & vbNewLine
+    Next s
+    f.WriteLine TSP
+    f.Close
+    
+    '// 刷新一下文件流，延时的效果
+    Set f = fs.OpenTextFile("C:\TSP\CDR_TO_TSP", 1, False)
+    Dim str
+    str = f.ReadAll()
+    f.Close
+    
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh: Application.Refresh
+Exit Function
+ErrorHandler:
+    Application.Optimization = False
+    On Error Resume Next
+End Function
+
+'//  TSP功能画线-多线段
+Private Function TSP_TO_DRAW_LINES()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup: Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
+  Dim str, arr, n
+  Dim line As Shape
+  str = f.ReadAll()
+  f.Close
+  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
+  str = f.ReadAll()
+  
+  str = VBA.Replace(str, vbNewLine, " ")
+  Do While InStr(str, "  ")
+    str = VBA.Replace(str, "  ", " ")
+  Loop
+  
+  arr = Split(str)
+  For n = 2 To UBound(arr) - 1 Step 4
+    x = Val(arr(n))
+    y = Val(arr(n + 1))
+    x1 = Val(arr(n + 2))
+    y1 = Val(arr(n + 3))
+
+    Set line = ActiveLayer.CreateLineSegment(x, y, x1, y1)
+    set_line_color line
+    
+    ' 调试线条顺序
+    puts x, y, (n + 2) / 4
+    
+  Next
+  
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
+  ActiveSelection.group
+  ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
+  
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh: Application.Refresh
+Exit Function
+ErrorHandler:
+    Application.Optimization = False
+    On Error Resume Next
+End Function
+
+'// 运行裁切线算法 Cut_Line_Algorithm.py
+Private Function START_Cut_Line_Algorithm(Optional ext As Double = 3)
+    cmd_line = "python C:\TSP\Cut_Line_Algorithm.py" & " " & ext
+    Shell cmd_line
+End Function
+
+'// 设置线条标记(颜色)
+Private Function set_line_color(line As Shape)
+  line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+End Function
+
+Public Sub puts(x, y, n)
+  Dim st As String
+  st = str(n)
+  Set s = ActiveLayer.CreateArtisticText(x, y, st)
+End Sub

zerobase/ChatGPT.bas

@@ -0,0 +1,276 @@
+Attribute VB_Name = "ChatGPT"
+Private Type Coordinate
+    x As Double
+    y As Double
+End Type
+
+Sub Z序排列()
+
+  ActiveDocument.Unit = cdrMillimeter
+  Dim dot As Coordinate
+  Dim s As Shape, ssr As ShapeRange
+  Dim cnt As Long: cnt = 1
+  Set ssr = ActiveSelectionRange
+
+  ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+  
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    s.OrderToFront
+    puts dot.x, dot.y, cnt: cnt = cnt + 1
+  Next s
+End Sub
+
+Sub U序排列()
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set xdict = CreateObject("Scripting.dictionary")
+  Set ydict = CreateObject("Scripting.dictionary")
+  Dim dot As Coordinate
+  Dim s As Shape, ssr As ShapeRange
+  Dim cnt As Long: cnt = 1
+  Set ssr = ActiveSelectionRange
+  
+  ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+  
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
+    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+  Next s
+  
+  inverter = 1   ' 交流频率控制
+  xc = xdict.Count: yc = ydict.Count
+
+  For cnt = 0 To ydict.Count - 1
+    If inverter Mod 2 = 0 Then
+        ssr.Sort " @shape1.Left > @shape2.Left", cnt * xc + 1, cnt * xc + xc
+    Else
+        ssr.Sort " @shape1.Left < @shape2.Left", cnt * xc + 1, cnt * xc + xc
+    End If
+    inverter = inverter + 1
+  Next cnt
+  
+  cnt = 1
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    s.OrderToFront
+    puts dot.x, dot.y, cnt: cnt = cnt + 1
+  Next s
+  
+End Sub
+
+
+Sub 计算行列()   ' 字典使用计算行列
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set xdict = CreateObject("Scripting.dictionary")
+  Set ydict = CreateObject("Scripting.dictionary")
+  Dim dot As Coordinate, Offset As Coordinate
+  Dim s As Shape, ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  
+  ' 当前选择物件的范围边界
+  set_lx = ssr.LeftX: set_rx = ssr.RightX
+  set_by = ssr.BottomY: set_ty = ssr.TopY
+  ssr(1).GetSize Offset.x, Offset.y
+  ' 当前选择物件 ShapeRange 初步排序
+  ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+  
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
+    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+  Next s
+  
+'  MsgBox "字典使用计算行列:" & xdict.Count & ydict.Count
+  Dim cnt As Long: cnt = 1
+  
+  ' 遍历字典，输出
+  Dim key As Variant
+  For Each key In xdict.keys
+      dot.x = xdict(key)
+      puts dot.x, set_by - Offset.y / 2, cnt
+      cnt = cnt + 1
+  Next key
+  
+  cnt = 1
+  For Each key In ydict.keys
+      dot.y = ydict(key)
+      puts set_lx - Offset.x / 2, dot.y, cnt
+      cnt = cnt + 1
+  Next key
+  
+End Sub
+
+Private Sub puts(x, y, n)
+  Dim st As String
+  st = str(n)
+  Set s = ActiveLayer.CreateArtisticText(0, 0, st)
+  s.CenterX = x: s.CenterY = y
+End Sub
+
+'// 对数组进行排序[单维]
+Public Function ArraySort(src As Variant) As Variant
+  Dim out As Long, i As Long, tmp As Variant
+  For out = LBound(src) To UBound(src) - 1
+    For i = out + 1 To UBound(src)
+      If src(out) > src(i) Then
+        tmp = src(i): src(i) = src(out): src(out) = tmp
+      End If
+    Next i
+  Next out
+  
+  ArraySort = src
+End Function
+
+
+
+Sub ShowMessage()
+    MsgBox "Hello, World!"
+End Sub
+
+
+Sub DictionaryExample()
+    ' 创建一个空的Dictionary
+    Dim myDict As Object
+    Set myDict = CreateObject("Scripting.Dictionary")
+    
+    ' 向Dictionary中添加键值对
+    myDict.Add "orange", 4
+    myDict.Add "banana", 2
+    myDict.Add "apple", 3
+    
+    ' 访问键值对
+    Debug.Print "The value of 'apple' is " & myDict("apple")
+    
+    ' 遍历Dictionary中的所有键值对
+    Dim key As Variant
+    For Each key In myDict.keys
+        Debug.Print key & " : " & myDict(key)
+    Next key
+    
+    ' 检查某个键是否存在
+    If myDict.Exists("orange") Then
+        Debug.Print "The key 'orange' exists"
+    End If
+    
+    ' 删除某个键值对
+    myDict.Remove "banana"
+    
+    ' 清空Dictionary
+    myDict.RemoveAll
+End Sub
+
+Sub tongji使用字典统计()
+
+  Dim s As Shape
+  Dim sr As ShapeRange
+  
+  Set sr = ActiveSelection.Shapes.FindShapes(Query:="@name='wk-y标记'")
+  
+  Dim stn As String, str As String
+  
+  Set d = CreateObject("Scripting.dictionary")
+  
+  For Each s In sr
+    If s.Type = cdrTextShape Then
+      If s.text.Type = cdrArtistic Then
+        stn = s.text.Story.text
+        If d.Exists(stn) = True Then
+          d.Item(stn) = d.Item(stn) + 1
+        Else
+          d.Add stn, 1
+        End If: End If: End If
+  Next s
+  
+  str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
+
+  a = d.keys: b = d.items
+  For i = 0 To d.Count - 1
+    str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
+  Next
+
+  ' 遍历Dictionary中的所有键值对
+  Dim key As Variant
+  For Each key In d.keys
+      Debug.Print key & " : " & d(key)
+  Next key
+
+  Debug.Print str
+End Sub
+
+
+
+
+Sub 正式U序排列()
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set xdict = CreateObject("Scripting.dictionary")
+  Set ydict = CreateObject("Scripting.dictionary")
+  Dim dot As Coordinate
+  Dim s As Shape, ssr As ShapeRange
+  Dim cnt As Long: cnt = 1
+  Set ssr = ActiveSelectionRange
+  
+  ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+  
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
+    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+  Next s
+  
+  inverter = 1   ' 交流频率控制
+  xc = xdict.Count: yc = ydict.Count
+
+  For cnt = 0 To ydict.Count - 1
+    If inverter Mod 2 = 0 Then
+        ssr.Sort " @shape1.Left > @shape2.Left", cnt * xc + 1, cnt * xc + xc
+    Else
+        ssr.Sort " @shape1.Left < @shape2.Left", cnt * xc + 1, cnt * xc + xc
+    End If
+    inverter = inverter + 1
+  Next cnt
+  
+  cnt = 1
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    s.OrderToFront
+    puts dot.x, dot.y, cnt: cnt = cnt + 1
+  Next s
+  
+    ActiveDocument.EndCommandGroup
+  '// 代码操作结束恢复窗口刷新
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+End Sub
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

zerobase/Hello_VBA.bas

@@ -0,0 +1,4 @@
+Attribute VB_Name = "Hello_VBA"
+Sub run()
+  VBA_FORM.Show 0
+End Sub

zerobase/PhotoForm.frm

@@ -0,0 +1,92 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} PhotoForm 
+   Caption         =   "对象批量转位图 by filon [玉环]"
+   ClientHeight    =   1800
+   ClientLeft      =   45
+   ClientTop       =   375
+   ClientWidth     =   4710
+   OleObjectBlob   =   "PhotoForm.frx":0000
+   ShowModal       =   0   'False
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "PhotoForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+#If VBA7 Then
+    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
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    
+#Else
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+#End If
+
+Private Const GWL_STYLE = (-16) '设置窗口样式
+Private Const WS_MINIMIZEBOX As Long = &H20000 '最小化
+
+Private Sub CovPhotos_Click()
+    On Error Resume Next
+    ActiveDocument.BeginCommandGroup
+    Dim a, Color As String
+    Dim b As Boolean
+    Dim i, dpi As Integer
+    
+    If ABox1.Value = False Then
+        a = False
+    Else
+        a = True
+    End If
+
+    b = True
+    If BBox2.Value = False Then b = False
+    
+    dpi = CInt(ComboBox2.text)
+    
+    Select Case ComboBox1.text
+      Case Is = "灰度"
+      Color = cdrGrayscaleImage
+      Case Is = "CMYK颜色"
+      Color = cdrCMYKColorImage
+      Case Is = "RGB颜色"
+      Color = cdrRGBColorImage
+      Case Is = "黑白"
+      Color = cdrBlackAndWhiteImage
+    End Select
+    
+    Dim s As Shapes
+    Set s = ActiveSelection.Shapes
+    If s Is Nothing Then
+        MsgBox "请先选中一个形状!"
+        Exit Sub
+    Else
+        For i = 1 To s.Count
+        Set s(i) = ActiveShape.ConvertToBitmapEx(Color, False, a, dpi, cdrNormalAntiAliasing, True, False, 95)
+        Next i
+    End If
+    ActiveDocument.EndCommandGroup
+End Sub
+
+
+Private Sub UserForm_Initialize()
+Dim hWndForm As Long
+Dim IStyle As Long
+hWndForm = FindWindow("ThunderDFrame", Me.Caption)  '获取窗口句柄
+IStyle = GetWindowLong(hWndForm, GWL_STYLE) '获取当前标题栏样式
+IStyle = IStyle Or WS_MINIMIZEBOX '设置最小化按钮
+SetWindowLong hWndForm, GWL_STYLE, IStyle  '显示最小化按钮
+    On Error Resume Next
+    ComboBox1.AddItem "灰度"
+    ComboBox1.AddItem "CMYK颜色"
+    ComboBox1.AddItem "RGB颜色"
+    ComboBox1.AddItem "黑白"
+    
+    ComboBox2.AddItem "300", 0
+    ComboBox2.AddItem "450", 1
+    ComboBox2.AddItem "600", 2
+End Sub
+

zerobase/Tools.bas

@@ -0,0 +1,836 @@
+Attribute VB_Name = "Tools"
+#If VBA7 Then
+  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
+#Else
+  Private Declare Sub Sleep Lib "kernel32" (ByValdwMilliseconds As Long)
+#End If
+
+Public Function wait()
+  Sleep 3000
+End Function
+
+Public Sub 填入居中文字(str)
+  Dim s As Shape
+  Dim x As Double, y As Double, Shift As Long
+  Dim b As Boolean
+  b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorIntersectSingle)
+  
+  str = VBA.Replace(str, vbNewLine, Chr(10))
+  str = VBA.Replace(str, Chr(10), vbNewLine)
+  Set s = ActiveLayer.CreateArtisticText(0, 0, str)
+  s.CenterX = x
+  s.CenterY = y
+End Sub
+
+Public Sub 尺寸标注()
+  ActiveDocument.Unit = cdrMillimeter
+  Set s = ActiveSelection
+  x = s.CenterX: y = s.TopY
+  sw = s.SizeWidth: sh = s.SizeHeight
+        
+  text = Int(sw) & "x" & Int(sh) & "mm"
+  Set s = ActiveLayer.CreateArtisticText(0, 0, text)
+  s.CenterX = x: s.BottomY = y + 5
+End Sub
+
+Public Sub 批量居中文字(str)
+  Dim s As Shape, sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  
+  For Each s In sr.Shapes
+    x = s.CenterX: y = s.CenterY
+    
+    Set s = ActiveLayer.CreateArtisticText(0, 0, str)
+    s.CenterX = x: s.CenterY = y
+  Next
+End Sub
+
+Public Sub 批量标注()
+  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 Sub
+
+Public Sub 智能群组()
+  Set s1 = ActiveSelectionRange.CustomCommand("Boundary", "CreateBoundary")
+  Set brk1 = s1.BreakApartEx
+
+  For Each s In brk1
+    Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, True)
+    sh.Shapes.All.group
+    s.Delete
+  Next
+End Sub
+
+
+' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+Public Function 群组居中页面()
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange, sh As Shape
+  Set OrigSelection = ActiveSelectionRange
+  Set sh = OrigSelection.group
+  
+  ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
+  ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+  
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+End Function
+
+
+Public Function 批量多页居中()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set sr = ActiveSelectionRange
+  total = sr.Count
+
+  '// 建立多页面
+  Set doc = ActiveDocument
+  doc.AddPages (total - 1)
+
+  Dim sh As Shape
+  
+  '// 遍历批量物件，放置物件到页面
+  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)
+ 
+   '// 物件居中页面
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+  Next i
+
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh:   Application.Refresh
+Exit Function
+
+ErrorHandler:
+  Application.Optimization = False
+  MsgBox "请先选择一些物件"
+  On Error Resume Next
+End Function
+
+
+'// 安全线: 点击一次建立辅助线，再调用清除参考线
+Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
+  Dim sr As ShapeRange
+  Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
+  If sr.Count <> 0 Then
+    sr.Delete
+    Exit Function
+  End If
+  
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+
+  With actnumber
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
+  End With
+  
+End Function
+
+Public Function splash_cnt()
+  splash.Show 0
+  splash.text1 = splash.text1 & ">"
+  Sleep 100
+End Function
+
+
+Public Function vba_cnt()
+  VBA_FORM.text1 = VBA_FORM.text1 & ">"
+  Sleep 100
+End Function
+
+Public Function 按面积排列(space_width As Double)
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.ReferencePoint = cdrCenter
+  
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+  ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+  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
+  Next sh
+
+  ActiveDocument.ReferencePoint = cdrTopLeft
+  
+  For Each s In ssr
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
+    cnt = cnt + 1
+    
+    vba_cnt
+
+  Next s
+
+
+'  写文件，可以EXCEL里统计
+'  Set fs = CreateObject("Scripting.FileSystemObject")
+'  Set f = fs.CreateTextFile("D:\size.txt", True)
+'  f.WriteLine str: f.Close
+
+  str = 分类汇总(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:="华文中宋")
+End Function
+ 
+'// 实现Excel里分类汇总功能
+Private Function 分类汇总(str As String) As String
+  Dim a, b, d, arr
+  str = VBA.Replace(str, vbNewLine, " ")
+  Do While InStr(str, "  ")
+      str = VBA.Replace(str, "  ", " ")
+  Loop
+  arr = Split(str)
+
+  Set d = CreateObject("Scripting.dictionary")
+
+  For i = 0 To UBound(arr) - 1
+    If d.Exists(arr(i)) = True Then
+      d.Item(arr(i)) = d.Item(arr(i)) + 1
+    Else
+       d.Add arr(i), 1
+    End If
+  Next
+
+  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
+  Next
+
+  分类汇总 = str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
+End Function
+
+
+' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
+Private Function lineangle(x1, y1, x2, y2) As Double
+  pi = 4 * VBA.Atn(1) ' 计算圆周率
+  If x2 = x1 Then
+    lineangle = 90: Exit Function
+  End If
+  lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
+End Function
+
+Public Function 角度转平()
+  On Error GoTo ErrorHandler
+'  ActiveDocument.ReferencePoint = cdrCenter
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2): sr.Rotate -a
+    ' sr.LastShape.Delete   '// 删除参考线
+  End If
+ErrorHandler:
+End Function
+
+Public Function 自动旋转角度()
+  On Error GoTo ErrorHandler
+'  ActiveDocument.ReferencePoint = cdrCenter
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
+    sr.LastShape.Delete   '// 删除参考线
+  End If
+ErrorHandler:
+End Function
+
+
+Public Function 交换对象()
+  Set sr = ActiveSelectionRange
+  If sr.Count = 2 Then
+    x = sr.LastShape.CenterX: y = sr.LastShape.CenterY
+    sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
+    sr.FirstShape.CenterX = x: sr.FirstShape.CenterY = y
+  End If
+End Function
+
+Public Function 参考线镜像()
+  On Error GoTo ErrorHandler
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    ActiveDocument.BeginCommandGroup "Mirror"
+    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
+    
+    ang = 90 - a  ' 镜像的旋转角度
+    For Each s In sr
+      With s
+        .Duplicate   ' // 复制物件保留，然后按 x1,y1 点 旋转
+        .RotationCenterX = x1
+        .RotationCenterY = y1
+        .Rotate ang
+        If Not byshape Then
+            lx = .LeftX
+            .Stretch -1#, 1#    ' // 通过拉伸完成镜像
+            .LeftX = lx
+            .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
+            .RotationCenterX = x1   '// 之前因为镜像，旋转中心点反了，重置回来
+            .RotationCenterY = y1
+            .Rotate -ang
+        End If
+        .RotationCenterX = .CenterX   '// 重置回旋转中心点为物件中心
+        .RotationCenterY = .CenterY
+      End With
+    Next s
+    ActiveDocument.EndCommandGroup
+  End If
+ErrorHandler:
+End Function
+
+
+Public Function autogroup(Optional group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
+  Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
+  Dim sp As SubPaths
+  Dim arr()
+  Dim s As Shape
+  If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.All
+  On Error GoTo errn
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  If ActiveSelection.Shapes.Count > 0 Then
+    gcnt = os.Shapes.Count
+    ReDim arr(1 To gcnt, 1 To gcnt)
+    Set sr_all = ActiveSelectionRange
+    sr_all.RemoveAll
+    ReDim arr(1 To gcnt, 1 To gcnt)
+    ActiveDocument.Unit = cdrTenthMicron
+    sgap = 10
+    If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
+      os.RemoveAll
+      For Each s In ActiveSelectionRange.Shapes
+          os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
+      Next s
+    End If
+    
+    For i = 1 To os.Shapes.Count
+      Set s1 = os.Shapes(i)
+      arr(i, i) = i
+      For j = 1 To os.Shapes.Count
+        Set s2 = os.Shapes(j)
+        If s2.LeftX < s1.RightX + sgap And s2.RightX > s1.LeftX - sgap And s2.BottomY < s1.TopY + sgap And s2.TopY > s1.BottomY - sgap Then
+          If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
+            Set isec = s1.Intersect(s2)
+            If Not isec Is Nothing Then
+              arr(i, j) = j
+              isec.CreateSelection
+              isec.Delete
+            End If
+          Else
+            arr(i, j) = j
+          End If
+        End If
+      Next j
+    Next i
+    
+    For i = 1 To gcnt
+      arr = collect_arr(arr, i, i)
+    Next i
+    
+    Set sr = ActiveSelectionRange
+
+    For i = 1 To gcnt
+      sr.RemoveAll
+      inar = 0
+      For j = 1 To gcnt
+        If arr(i, j) > 0 Then
+          sr.Add os.Shapes(j)
+          inar = inar + 1
+        End If
+      Next j
+      If inar > 1 Then
+        If group = "group" Then
+          If shft < 4 Then sr_all.Add sr.group
+        End If
+      Else
+        If sr.Shapes.Count > 0 Then sr_all.AddRange sr
+      End If
+    Next i
+  Set autogroup = sr_all
+  End If
+
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  Exit Function
+errn:
+  Application.Optimization = False
+End Function
+
+Public Function collect_arr(arr, ci, ki)
+    lim = UBound(arr)
+    For k = 1 To lim
+        If arr(ki, k) > 0 Then
+            arr(ci, k) = k
+            If ki <> ci Then arr(ki, k) = Empty
+            If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
+        End If
+    Next k
+    'If ki <> ci Then arr(ki, ki) = Empty
+    collect_arr = arr
+End Function
+
+
+
+Sub Make_Sizes()
+    ActiveDocument.Unit = cdrMillimeter
+    Set os = ActiveSelectionRange
+    If os.Count > 0 Then
+    For Each s In os.Shapes
+      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
+      
+      Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
+      ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
+      
+    Next s
+    End If
+End Sub
+
+'''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
+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.UngroupAllEx.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:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+
+
+'// 修复圆角缺角到直角
+Public Sub corner_off()
+    Dim os As ShapeRange
+    Dim s As Shape, fir As Shape, ci As Shape
+    Dim nd As Node, nds As Node, nde As Node
+
+    Set os = ActiveSelectionRange
+    ud = ActiveDocument.Unit
+    ActiveDocument.Unit = cdrMillimeter
+On Error GoTo errn
+    ActiveDocument.BeginCommandGroup "corners off"
+    'Application.Optimization = True
+    selec = False
+    If os.Shapes.Count = 1 Then
+        Set s = os.FirstShape
+        If Not s.Curve Is Nothing Then
+            For Each nd In s.Curve.Nodes
+                If nd.Selected Then
+                    selec = True
+                    Exit For
+                End If
+            Next nd
+        End If
+    End If
+    
+    If os.Shapes.Count > 1 Or Not selec Then
+        os.ConvertToCurves
+        For Each s In os.Shapes
+            Set nds = Nothing
+            Set nde = Nothing
+            For k = 1 To 3
+            For i = 1 To s.Curve.Nodes.Count
+                If i <= s.Curve.Nodes.Count Then
+                    Set nd = s.Curve.Nodes(i)
+                    If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
+                        If Abs(nd.PrevSegment.Length - nd.NextSegment.Length) < (nd.PrevSegment.Length + nd.NextSegment.Length) / 30 And nd.PrevSegment.Type = cdrCurveSegment And nd.NextSegment.Type = cdrCurveSegment Then
+                            corner_off_make s, nd.Previous, nd.Next
+                        ElseIf Not nd.Next.NextSegment Is Nothing Then
+                            If (nd.PrevSegment.Type = cdrLineSegment Or Abs(Abs(nd.PrevSegment.StartingControlPointAngle - nd.PrevSegment.EndingControlPointAngle) - 180) < 1) _
+                                And (nd.Next.NextSegment.Type = cdrLineSegment Or Abs(Abs(nd.Next.NextSegment.StartingControlPointAngle - nd.Next.NextSegment.EndingControlPointAngle) - 180) < 1) _
+                                And nd.NextSegment.Type = cdrCurveSegment Then
+                                    corner_off_make s, nd, nd.Next
+                            End If
+                       End If
+                    End If
+                End If
+            Next i
+            Next k
+            
+             
+        Next s
+    ElseIf os.Shapes.Count = 1 And selec Then
+        Set nds = Nothing
+        Set nde = Nothing
+        For Each nd In s.Curve.Nodes
+            If Not nd.Selected And Not nd.Next.Selected Then Exit For
+        Next nd
+        If Not nd Is s.Curve.Nodes.Last Then
+            For i = 1 To s.Curve.Nodes.Count
+                Set nd = nd.Next
+                If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
+                If Not nds Is Nothing And nd.Selected Then Set nde = nd
+                If nde Is Nothing And nds Is Nothing And nd.Selected Then Set nds = nd
+            Next i
+            
+            If Not nds Is Nothing And Not nde Is Nothing Then
+                'ActiveLayer.CreateEllipse2 nds.PositionX, nds.PositionY, nde.PrevSegment.Length / 4
+                'ActiveLayer.CreateEllipse2 nde.PositionX, nde.PositionY, nde.PrevSegment.Length / 4
+                corner_off_make s, nds, nde
+            End If
+        End If
+    End If
+errn:
+    Application.Optimization = False
+    ActiveDocument.EndCommandGroup
+    Application.Refresh
+    ActiveDocument.Unit = ud
+End Sub
+
+Private Sub corner_off_make(s As Shape, nds As Node, nde As Node)
+    Dim l1 As Shape, l2 As Shape
+    Dim os As ShapeRange
+    Dim ss As Shape
+    ud = ActiveDocument.Unit
+    ActiveDocument.Unit = cdrMillimeter
+
+    Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
+    l1.RotationCenterX = nds.PositionX
+    l1.RotationAngle = nds.PrevSegment.EndingControlPointAngle + 180
+    
+    Set l2 = ActiveLayer.CreateLineSegment(nde.PositionX, nde.PositionY, nde.PositionX + s.SizeWidth * 3, nde.PositionY)
+    l2.RotationCenterX = nde.PositionX
+    l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
+    
+    Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
+    If lcross.Count > 0 Then
+        cx = lcross(1).PositionX
+        cy = lcross(1).PositionY
+        sx = nds.PositionX
+        sy = nds.PositionY
+        ex = nde.PositionX
+        ey = nde.PositionY
+        
+        l1.Curve.Nodes.Last.PositionX = cx
+        l1.Curve.Nodes.Last.PositionY = cy
+        l2.Curve.Nodes.Last.PositionX = cx
+        l2.Curve.Nodes.Last.PositionY = cy
+        
+        s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
+        Set os = s.BreakApartEx
+        oscnt = os.Shapes.Count
+        For Each ss In os.Shapes
+            If ss.Curve.Nodes.First.PositionX = ex And ss.Curve.Nodes.First.PositionY = ey Then Set s2 = ss
+            If ss.Curve.Nodes.Last.PositionX = sx And ss.Curve.Nodes.Last.PositionY = sy Then Set s1 = ss
+            If ss.Curve.Nodes.First.PositionX = sx And ss.Curve.Nodes.First.PositionY = sy Then ss.Delete
+        Next ss
+        
+        If s1.Curve.Segments.Last.Type = cdrLineSegment Or Abs(Abs(s1.Curve.Segments.Last.StartingControlPointAngle - s1.Curve.Segments.Last.EndingControlPointAngle) - 180) < 1 Then
+            s1.Curve.Nodes.Last.PositionX = lcross(1).PositionX
+            s1.Curve.Nodes.Last.PositionY = lcross(1).PositionY
+            l1.Delete
+        Else
+            Set s1 = l1.Weld(s1)
+        End If
+        If oscnt = 2 Then Set s2 = s1
+        If s2.Curve.Segments.First.Type = cdrLineSegment Or Abs(Abs(s2.Curve.Segments.First.StartingControlPointAngle - s2.Curve.Segments.First.EndingControlPointAngle) - 180) < 1 Then
+            s2.Curve.Nodes.First.PositionX = lcross(1).PositionX
+            s2.Curve.Nodes.First.PositionY = lcross(1).PositionY
+            l2.Delete
+        Else
+            Set s2 = l2.Weld(s2)
+        End If
+        If oscnt > 2 Then Set s2 = s1.Weld(s2)
+        s2.CustomCommand "ConvertTo", "JoinCurves", 0.1
+        Set s = s2
+    Else
+        l1.Delete
+        l2.Delete
+    End If
+    ActiveDocument.Unit = ud
+End Sub
+
+Sub ExportNodePositions()
+    Dim s As Shape, n As Node
+    Dim srActiveLayer As ShapeRange
+    Dim x As Double, y As Double
+    Dim strNodePositions As String
+    
+    ActiveDocument.Unit = cdrMillimeter
+    
+    'Get all the curve shapes on the Active Layer
+    '获取Active Layer上的所有曲线形状
+    Set srActiveLayer = ActiveLayer.Shapes.FindShapes(Query:="@type='curve'")
+    'This is another way you can get only the curve shapes
+    '这是另一种你只能得到曲线形状的方法
+    'Set srActiveLayer = ActiveLayer.Shapes.FindShapes.FindAnyOfType(cdrCurveShape)
+    
+    'Loop through each curve
+    '遍历每条曲线
+    For Each s In srActiveLayer.Shapes
+        'Loop though each node in the curve and get the position
+        '遍历曲线中的每个节点并获取位置
+        For Each n In s.Curve.Nodes
+            n.GetPosition x, y
+            strNodePositions = strNodePositions & "x: " & x & " y: " & y & vbCrLf
+        Next n
+    Next s
+    
+    'Save the node positions to a file
+    '将节点位置保存到文件
+    Open "C:\Temp\NodePositions.txt" For Output As #1
+        Print #1, strNodePositions
+    Close #1
+End Sub
+
+Sub 服务器T()
+   Dim mark As Shape
+   Dim sr As ShapeRange
+   
+    Set sr = ActiveSelectionRange
+        If (Shift And 1) <> 0 Then ActivePage.Shapes.FindShapes(Query:="@type ='rectangle'or @type ='curve'or @type ='Ellipse'or @type ='Polygon'").CreateSelection
+        sr.Shapes.FindShapes(Query:="@type ='rectangle'or @type ='curve'or @type ='Ellipse'or @type ='Polygon'").ConvertToCurves
+   If sr.Count = 0 Then Exit Sub
+   
+    ' CorelDRAW设置原点标记导出DXF使用
+    
+    ' 更新原点标记，现在能设置任意坐标点
+    Dim MarkPos_Array() As Double
+    MarkPos_Array = Get_MarkPosition
+    AtOrigin MarkPos_Array(0), MarkPos_Array(1)
+    
+    sr.Add ActiveDocument.ActiveShape
+     Set mark = ActiveDocument.ActiveShape
+   ActiveDocument.ClearSelection
+   sr.CreateSelection
+ '    Set mark = ActiveDocument.ActiveShape
+ '  If FileExists("d:\mytempdxf.dxf") Then
+ '   DeleteFile "d:\mytempdxf.dxf"
+ '  End If
+    
+ SaveDXF "d:\mytempdxf.dxf"
+ 
+ '  Do While FileExists("d:\mytempdxf.dxf") = False
+ '       DoEvents
+ '       Delay 1
+ '   Loop
+ Shell Application.GMSManager.GMSPath & "tuznr.exe d:/mytempdxf.dxf", 1
+    
+ mark.Delete
+End Sub
+
+Sub SaveDXF(FileName As String)
+    Dim expopt As StructExportOptions
+    Set expopt = CreateStructExportOptions
+    expopt.UseColorProfile = False
+    Dim expflt As ExportFilter
+    Set expflt = ActiveDocument.ExportEx(FileName, cdrDXF, cdrSelection, expopt)
+    With expflt
+        .BitmapType = 0 ' FilterDXFLib.dxfBitmapJPEG
+        .TextAsCurves = True
+        .Version = 3 ' FilterDXFLib.dxfVersion13
+        .Units = 3 ' FilterDXFLib.dxfMillimeters
+        .FillUnmapped = True
+        .Finish
+    End With
+End Sub
+
+' 更新原点标记函数，现在能设置任意坐标点
+Sub AtOrigin(Optional px As Double = 0#, Optional py As Double = 0#)
+  Dim doc As Document: Set doc = ActiveDocument
+  doc.Unit = cdrMillimeter
+
+  '// 导入原点标记标记文件 OriginMark.cdr 解散群组
+  doc.ActiveLayer.Import path & "GMS\OriginMark.cdr"
+  doc.ReferencePoint = cdrCenter
+  doc.Selection.Ungroup
+
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  '// 按 MarkName 名称查找 标记物件
+  For Each sh In shs
+    If "AtOrigin" = sh.ObjectData("MarkName").Value Then
+      sh.SetPosition px, py
+    Else
+      sh.Delete   ' 不需要的标记删除
+    End If
+  Next sh
+End Sub
+
+' 使用 GlobalUserData 对象保存 Mark标记坐标文本，调用函数能设置文本
+Public Function Mark_SetPosition() As String
+  Dim text As String
+  If GlobalUserData.Exists("MarkPosition", 1) Then
+    text = GlobalUserData("MarkPosition", 1)
+  End If
+  text = InputBox("请输入Mark标记坐标(x,y),空格或逗号间隔", "设置Mark标记坐标(x,y),单位(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("MarkPosition", 1) = text
+  Mark_SetPosition = text
+End Function
+
+' 调用设置Mark标记坐标功能，返回 数组(x,y)
+Public Function Get_MarkPosition() As Double()
+  Dim MarkPos_Array(0 To 1) As Double
+  Dim str, arr
+  
+  str = Mark_SetPosition
+
+  ' 替换 逗号 为空格
+  str = VBA.Replace(str, ",", " ")
+  Do While InStr(str, "  ") '多个空格换成一个空格
+      str = VBA.Replace(str, "  ", " ")
+  Loop
+  arr = Split(str)
+  
+  MarkPos_Array(0) = Val(arr(0))
+  MarkPos_Array(1) = Val(arr(1))
+  
+  Debug.Print MarkPos_Array(0), MarkPos_Array(1)  ' 视图->立即窗口，调试显示
+  
+  Get_MarkPosition = MarkPos_Array
+  
+End Function
+
+Public Function SetNames()
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+
+#If VBA7 Then
+  ssr.Sort " @shape1.left<@shape2.left"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+  Dim text As String
+  Dim lines() As String
+  ' 提取文本信息，切割文本
+  If ssr(1).Type = cdrTextShape Then
+    If ssr(1).text.Type = cdrArtistic Then
+      text = ssr(1).text.Story.text
+      lines = Split(text, vbCr)
+      ssr.Remove 1
+  #If VBA7 Then
+      ssr.Sort " @shape1.top>@shape2.top"
+  #Else
+  ' X4 不支持 ShapeRange.sort
+  #End If
+    End If
+  Else
+      MsgBox "请把多行文本放最左边"
+      Exit Function
+  End If
+    
+' Debug.Print ssr.Count, UBound(lines), LBound(lines)
+' 给物件设置名称，用处:批量导出可以有一个名称
+  i = 0
+  If ssr.Count <= UBound(lines) + 1 Then
+    For Each s In ssr
+      s.Name = lines(i)
+      i = i + 1
+    Next s
+  End If
+  
+  If ssr.Count <> UBound(lines) + 1 Then MsgBox "文本行:" & (UBound(lines) + 1) & vbNewLine & "右边物件:" & ssr.Count
+    
+End Function
+
+Sub Nodes_TO_TSP()
+    Set fs = CreateObject("Scripting.FileSystemObject")
+    Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+    ActiveDocument.Unit = cdrMillimeter
+
+    Dim s As Shape, ssr As ShapeRange
+    Set ssr = ActiveSelectionRange
+
+    Dim TSP As String
+    TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
+
+    For Each s In ssr
+        lx = s.LeftX:   rx = s.RightX
+        By = s.BottomY: ty = s.TopY
+        TSP = TSP & lx & " " & By & vbNewLine
+        TSP = TSP & lx & " " & ty & vbNewLine
+        TSP = TSP & rx & " " & By & vbNewLine
+        TSP = TSP & rx & " " & ty & vbNewLine
+    Next s
+    f.WriteLine TSP
+    f.Close
+End Sub
+
+'// 获得剪贴板文本字符
+Public Function GetClipBoardString() As String
+  On Error Resume Next
+  Dim MyData As New DataObject
+  GetClipBoardString = ""
+  MyData.GetFromClipboard
+  GetClipBoardString = MyData.GetText
+  Set MyData = Nothing
+End Function

zerobase/VBA_FORM.frm

@@ -0,0 +1,230 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} VBA_FORM 
+   Caption         =   "Hello_VBA"
+   ClientHeight    =   7995
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   6180
+   OleObjectBlob   =   "VBA_FORM.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "VBA_FORM"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Private Sub AutoRotate_Click()
+  Tools.自动旋转角度
+End Sub
+
+Private Sub btn_autoalign_bycolumn_Click()
+  autogroup("group", 1).CreateSelection
+End Sub
+
+Private Sub btn_corners_off_Click()
+  Tools.corner_off
+End Sub
+
+Private Sub CommandButton1_Click()
+  autogroup("group", 2).CreateSelection
+End Sub
+
+
+Private Sub CB_AQX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    Tools.guideangle ActiveSelectionRange, 0#   ' 右键 0距离贴紧
+  ElseIf Shift = fmCtrlMask Then
+    Tools.guideangle ActiveSelectionRange, 4    ' 左键安全范围 4mm
+  Else
+    Tools.guideangle ActiveSelectionRange, -10     ' Ctrl + 鼠标左键
+  End If
+End Sub
+
+Private Sub CB_BZCC_Click()
+  Tools.尺寸标注
+End Sub
+
+
+Private Sub CB_ECWZ_Click()
+  Tools.填入居中文字 GetClipBoardString
+End Sub
+
+Private Sub CB_JDZP_Click()
+  Tools.角度转平
+End Sub
+
+Private Sub CB_JHDX_Click()
+  Tools.交换对象
+End Sub
+
+Private Sub CB_make_sizes_Click()
+  Tools.Make_Sizes
+End Sub
+
+Private Sub CB_PLBZ_Click()
+  Tools.批量标注
+End Sub
+
+Private Sub CB_PLDYJZ_Click()
+  Tools.批量多页居中
+End Sub
+
+Private Sub CB_PLWZ_Click()
+  Tools.批量居中文字 "CorelVBA批量文字"
+End Sub
+
+Private Sub CB_QZJZ_Click()
+  Tools.群组居中页面
+End Sub
+
+
+Private Sub CB_SIZESORT_Click()
+    splash.Show 1
+End Sub
+
+Private Sub CB_VBA_Click()
+  MsgBox "你好 CorelVBA!"
+End Sub
+
+Private Sub CB_VBA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  CB_VBA.BackColor = RGB(255, 0, 0)
+End Sub
+
+
+Private Sub CB_ZDJD_Click()
+  Tools.自动旋转角度
+End Sub
+
+Private Sub CB_mirror_by_line_Click()
+  Tools.参考线镜像
+End Sub
+
+
+Private Sub CommandButton2_Click()
+  Tools.服务器T
+End Sub
+
+Private Sub CommandButton3_Click()
+    Dim sr As ShapeRange
+    Dim shr As ShapeRange
+
+    Set sr = ActiveSelectionRange
+    Set shr = ActivePage.Shapes.All
+
+    If sr.Shapes.Count = 0 Then
+        shr.CreateSelection '所有对象
+    Else
+        shr.RemoveRange sr
+        shr.CreateSelection '不在原选择范围内的对象
+    End If
+End Sub
+
+Private Sub ExportNodePot_Click()
+  Tools.ExportNodePositions
+End Sub
+
+Private Sub Photo_Form_Click()
+  PhotoForm.Show 0
+End Sub
+
+Private Sub SetNames_Click()
+  Tools.SetNames
+End Sub
+
+Private Sub SplitSegment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    MsgBox "左键拆分线段，Ctrl合并线段"
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Split_Segment
+  Else
+    ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
+    Application.Refresh
+  End If
+End Sub
+
+Private Sub Image4_Click()
+    cmd_line = "Notepad  D:\备忘录.txt"
+    Shell cmd_line, vbNormalNoFocus
+End Sub
+
+Private Sub Image5_Click()
+  Shell "Calc"
+End Sub
+
+Private Sub LevelRuler_Click()
+  Tools.角度转平
+End Sub
+
+Private Sub MakeSizes_Click()
+  ZCOPY.Show 0
+End Sub
+
+Private Sub MirrorLine_Click()
+  Tools.参考线镜像
+End Sub
+
+Private Sub SortCount_Click()
+  Tools.按面积排列 50
+End Sub
+
+Private Sub SwapShape_Click()
+  Tools.交换对象
+End Sub
+
+
+Private Sub ZNQZ_Click()
+  Tools.智能群组
+End Sub
+
+Private Sub 读取文本_Click()
+  AutoCutLines.AutoCutLines
+End Sub
+
+Sub 读取每一行数据()
+    Dim txt As Object, t As Object, path As String
+    Set txt = CreateObject("Scripting.FileSystemObject")
+    
+    Dim a
+    ' 指定路径
+    path = "R:\Temp.txt"
+    ' “1”表示只读打开，“2”表示写入，True表示目标文件不存在时是创建
+    Set t = txt.OpenTextFile(path, 1, True)
+    '--------------------------
+    ' 读取每一行并把内容显示出来
+    Do While Not t.AtEndOfStream
+'        a = t.ReadLine
+        a = a & t.ReadLine & vbNewLine
+    TextBox1.Value = a
+    Loop
+    '--------------------------
+    ' 打开文档，注意“notepad.exe ”最后有空格
+    Shell "notepad.exe " & path, vbNormalFocus
+    ' 释放变量
+    Set t = Nothing
+    Set txt = Nothing
+End Sub
+
+
+
+Private Sub 裁切线_Click()
+ AutoCutLines.AutoCutLines
+ 
+End Sub
+
+
+Private Sub 手动拼版_Click()
+  ArrangeForm.Show 0
+End Sub
+
+Private Sub 算法计算_Click()
+  ChatGPT.计算行列
+End Sub
+
+Private Sub Z序排列_Click()
+    ChatGPT.Z序排列
+End Sub
+
+Private Sub U序排列_Click()
+  ChatGPT.正式U序排列
+End Sub

zerobase/ZCOPY.frm

@@ -0,0 +1,308 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ZCOPY 
+   Caption         =   "UserForm1"
+   ClientHeight    =   3855
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   4860
+   OleObjectBlob   =   "ZCOPY.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "ZCOPY"
+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)
+    If get_events("btn_square_hi", Shift, Button) = "exit" Then Exit Sub
+    Set os = ActiveSelectionRange
+    Set ss = os.Shapes
+    uc = 0
+    For Each s In ss
+        s.SizeWidth = s.SizeHeight
+        uc = uc + 1
+    Next s
+    Application.Refresh
+    If ch_main_switch Then ActiveWindow.Activate
+End Sub
+
+
+Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+    If get_events("btn_square_wi", Shift, Button) = "exit" Then Exit Sub
+    Set os = ActiveSelectionRange
+    Set ss = os.Shapes
+    uc = 0
+    For Each s In ss
+        s.SizeHeight = s.SizeWidth
+        uc = uc + 1
+    Next s
+    Application.Refresh
+    If ch_main_switch Then ActiveWindow.Activate
+End Sub
+
+Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+    If get_events("btn_makesizes", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_up", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_dn", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_lf", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_ri", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_btw_up", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_btw_dn", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_btw_lf", Shift, Button) = "exit" Then Exit Sub
+    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)
+    If get_events("btn_sizes_btw_ri", Shift, Button) = "exit" Then Exit Sub
+    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

zerobase/splash.frm

@@ -0,0 +1,70 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} splash 
+   Caption         =   "UserForm1"
+   ClientHeight    =   4020
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   8100
+   OleObjectBlob   =   "splash.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "splash"
+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 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
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
+#Else
+    Private Declare 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 Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+#End If
+
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+Private switch As Boolean
+
+
+Private Sub UserForm_Initialize()
+  Dim IStyle As Long
+  Dim hWnd As Long
+  
+  hWnd = FindWindow("ThunderDFrame", Me.Caption)
+
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
+
+End Sub
+
+' 经过优化改写，勉强够用了
+Private Sub UserForm_Activate()
+  Me.text1 = Me.text1 + "功能:按面积排列"
+  
+  Unload VBA_FORM
+  ActiveWindow.Refresh:    Application.Refresh
+  DoEvents
+
+  Tools.按面积排列 50
+  
+  'Close the window.
+  Unload Me
+End Sub
+
+