哪位屌大帮忙看看，这里怎么改成往下对齐分布

菲凡制版

Private Sub zxdq_Click()
    ActiveDocument.BeginCommandGroup "左对齐10mm间距分布" ' 开始撤销组，修改了描述以体现间距变化
    DistributeVerticallyWithTenMmSpacing
    ActiveDocument.EndCommandGroup  '结束撤销组
End Sub

Sub DistributeVerticallyWithTenMmSpacing()
    Dim curSelection As ShapeRange
    Dim i As Integer
    Dim curLeft As Double
    Dim curBottom As Double
    Dim sortedShapes() As Shape

    ' 获取当前选定对象
    Set curSelection = ActiveSelectionRange

    ' 检查用户是否选中了至少两个对象
    If curSelection.Count < 2 Then
        MsgBox "请选中2个或以上数量的对象。"
        Exit Sub
    End If
    If Not curSelection Is Nothing Then
        ' 创建一个形状数组以便对其进行排序
        ReDim sortedShapes(1 To curSelection.Count)
        For i = 1 To curSelection.Count
            Set sortedShapes(i) = curSelection(i)
        Next i

        ' 按左下角坐标对形状数组进行排序，保证后续能基于此有序排列图形
        SortShapesByLeftBottom sortedShapes

        ' 设置第一个形状的位置
        curLeft = sortedShapes(1).LeftX
        curBottom = sortedShapes(1).BottomY

        ' 调整每个对象的位置，实现垂直方向间距为10mm的分布
        For i = 1 To UBound(sortedShapes)
            sortedShapes(i).LeftX = curLeft
            sortedShapes(i).BottomY = curBottom
            curBottom = sortedShapes(i).TopY + 10 ' 这里加上10mm间距，更新为下一个对象的底部位置（基于当前对象顶部加间距）
        Next i
    End If
End Sub

Sub SortShapesByLeftBottom(arr() As Shape)
    Dim i As Long
    Dim j As Long
    Dim tempShape As Shape
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            ' 统一按照先比较LeftX坐标，如果LeftX相同再比较BottomY坐标的逻辑来排序
            If arr(j).LeftX < arr(i).LeftX Then
                Set tempShape = arr(i)
                Set arr(i) = arr(j)
                Set arr(j) = tempShape
            ElseIf arr(j).LeftX = arr(i).LeftX Then
                If arr(j).BottomY < arr(i).BottomY Then
                    Set tempShape = arr(i)
                    Set arr(i) = arr(j)
                    Set arr(j) = tempShape
                End If
            End If
        Next j
    Next i
End Sub

Private Sub dydq_Click()
    ActiveDocument.BeginCommandGroup '开始撤销组
    DistributeHorizontallyWithTenMmSpacing
    ActiveDocument.EndCommandGroup '结束撤销组
End Sub

Sub DistributeHorizontallyWithTenMmSpacing()
    Dim curSelection As ShapeRange
    Dim i As Integer
    Dim curLeft As Double
    Dim curTop As Double
    Dim sortedShapes() As Shape

    ' 获取当前选定对象
    Set curSelection = ActiveSelectionRange

    ' 检查用户是否选中了至少两个对象
    If curSelection.Count < 2 Then
        MsgBox "请选中2个或以上数量的对象。"
        Exit Sub
    End If
    If Not curSelection Is Nothing Then
        ' 创建一个形状数组以便对其进行排序
        ReDim sortedShapes(1 To curSelection.Count)
        For i = 1 To curSelection.Count
            Set sortedShapes(i) = curSelection(i)
        Next i

        ' 按左下角坐标对形状数组进行排序（这里使用统一后的SortShapesByLeftBottom过程）
        SortShapesByLeftBottom sortedShapes

        ' 设置第一个形状的位置
        curLeft = sortedShapes(1).LeftX
        curTop = sortedShapes(1).TopY

        ' 调整每个对象的位置，实现水平方向间距为10mm的分布
        For i = 1 To UBound(sortedShapes)
            sortedShapes(i).LeftX = curLeft
            sortedShapes(i).TopY = curTop
            curLeft = sortedShapes(i).RightX + 10 ' 这里加上10mm间距，更新为下一个对象的左边位置（基于当前对象右边加间距）
        Next i
    End If
End Sub

w2545

1. Option Explicit
   
2. '寻找最左边的对象索引
   
3. Function FindLeftShap() As Integer
   
4. Dim l As Integer
   
5. l = 23000 'CDR工作区域右边最大值（近似），没有明确的文档说明
   
6. Dim i As Integer
   
7. Dim s As Integer
   
8. For i = 1 To ActiveSelection.Shapes.Count
   
9. If ActiveSelection.Shapes(i).LeftX < l Then
   
10. l = ActiveSelection.Shapes(i).LeftX
    
11. s = i
    
12. End If
    
13. Next
    
14. FindLeftShap = s
    
15. End Function
    
16. Sub xia()’----------------------------------------------------------------
    
17. BeginOpt "22"
    
18. Dim OL As Integer '原始对象最左值
    
19. OL = 2300
    
20. Dim c As Integer '对象计数器
    
21. c = 0
    
22. Dim sp As ShapeRange
    
23. Dim sh As Shape, sr As ShapeRange
    
24. Set sr = ActiveSelectionRange
    
25.     sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
    
26. While sr.Shapes.Count > c
    
27. Set sh = sr.Shapes(FindLeftShap())
    
28. If OL > sh.LeftX Then OL = sh.LeftX
    
29. Set sp = New ShapeRange
    
30. Dim i As Integer
    
31. For i = 1 To sr.Shapes.Count
    
32. '获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
    
33. sr.Shapes(i).BottomY = sh.BottomY '与最左一个对象底部对齐
    
34. If sp.Count > 0 Then sr.Shapes(i).LeftX = sp(sp.Count).LeftX + sp(sp.Count).SizeWidth + index.jianju
    
35. sp.Add sr.Shapes(i)
    
36. Next
    
37. c = c + 1
    
38. Wend
    
39. EndOpt
    
40. End Sub
    
41. Sub zuo()‘---------------------------------------------------------------
    
42. On Error Resume Next
    
43. BeginOpt "11"
    
44. Dim OL As Integer '原始对象最左值
    
45. OL = 2300
    
46. Dim c As Integer '对象计数器
    
47. c = 0
    
48. Dim sp As ShapeRange
    
49. Dim sh As Shape, sr As ShapeRange
    
50. Set sr = ActiveSelectionRange
    
51.     sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
    
52. While sr.Shapes.Count > c
    
53. Set sh = sr.Shapes(FindLeftShap())
    
54. If OL > sh.LeftX Then OL = sh.LeftX
    
55. Set sp = New ShapeRange
    
56. Dim i As Integer
    
57. For i = 1 To sr.Shapes.Count
    
58. '获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
    
59. sr.Shapes(i).LeftX = sh.LeftX '与最左一个对象左边对齐
    
60. If sp.Count > 0 Then sr.Shapes(i).TopY = sp(sp.Count).TopY - sp(sp.Count).SizeHeight - index.jianju
    
61. sp.Add sr.Shapes(i)
    
62. Next
    
63. c = c + 1
    
64. Wend
    
65. EndOpt
    
66. End Sub
    
67. Sub shang()‘---------------------------------------------------
    
68. BeginOpt "33"
    
69. Dim OL As Integer '原始对象最左值
    
70. OL = 2300
    
71. Dim c As Integer '对象计数器
    
72. c = 0
    
73. Dim sp As ShapeRange
    
74. Dim s As Shape, sr As ShapeRange
    
75. Set sr = ActiveSelectionRange
    
76.     sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
    
77. While sr.Shapes.Count > c
    
78. Set s = sr.Shapes(FindLeftShap())
    
79. If OL > s.LeftX Then OL = s.LeftX
    
80. Set sp = New ShapeRange
    
81. Dim i As Integer
    
82. For i = 1 To sr.Shapes.Count
    
83. '获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
    
84. sr.Shapes(i).TopY = s.TopY '与最左一个对象底部对齐
    
85. If sp.Count > 0 Then sr.Shapes(i).LeftX = sp(sp.Count).LeftX + sp(sp.Count).SizeWidth + index.jianju
    
86. sp.Add sr.Shapes(i)
    
87. Next
    
88. c = c + 1
    
89. Wend
    
90. EndOpt
    
91. End Sub
    
92. Sub you()’----------------------------------------------------------------------
    
93. BeginOpt "44"
    
94. Dim OL As Integer '原始对象最左值
    
95. OL = 2300
    
96. Dim c As Integer '对象计数器
    
97. c = 0
    
98. Dim sp As ShapeRange
    
99. Dim s As Shape, sr As ShapeRange
    
100. Set sr = ActiveSelectionRange
     
101.     sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
     
102. While sr.Shapes.Count > c
     
103. Set s = sr.Shapes(FindLeftShap())
     
104. If OL > s.LeftX Then OL = s.LeftX
     
105. Set sp = New ShapeRange
     
106. Dim i As Integer
     
107. For i = 1 To sr.Shapes.Count
     
108. sr.Shapes(i).RightX = s.RightX '与最左一个对象左边对齐
     
109. If sp.Count > 0 Then sr.Shapes(i).TopY = sp(sp.Count).TopY - sp(sp.Count).SizeHeight - index.jianju
     
110. sp.Add sr.Shapes(i)
     
111. Next
     
112. c = c + 1
     
113. Wend
     
114. EndOpt
     
115. End Sub
     

复制代码

想见江南

垂直居中对齐，水平居中对齐，垂直均匀分布，水平均匀分布用这几个快捷键还不够吗？我觉得系统自带的快捷对齐已经够用了