哪位屌大帮忙看看，这里怎么改成往下对齐分布
本帖最后由 菲凡制版 于 2025-1-8 14:23 编辑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 于 2025-1-8 21:08 编辑Option Explicit
'寻找最左边的对象索引
Function FindLeftShap() As Integer
Dim l As Integer
l = 23000 'CDR工作区域右边最大值（近似），没有明确的文档说明
Dim i As Integer
Dim s As Integer
For i = 1 To ActiveSelection.Shapes.Count
If ActiveSelection.Shapes(i).LeftX < l Then
l = ActiveSelection.Shapes(i).LeftX
s = i
End If
Next
FindLeftShap = s
End Function
Sub xia()’----------------------------------------------------------------
BeginOpt "22"
Dim OL As Integer '原始对象最左值
OL = 2300
Dim c As Integer '对象计数器
c = 0
Dim sp As ShapeRange
Dim sh As Shape, sr As ShapeRange
Set sr = ActiveSelectionRange
sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
While sr.Shapes.Count > c
Set sh = sr.Shapes(FindLeftShap())
If OL > sh.LeftX Then OL = sh.LeftX
Set sp = New ShapeRange
Dim i As Integer
For i = 1 To sr.Shapes.Count
'获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
sr.Shapes(i).BottomY = sh.BottomY '与最左一个对象底部对齐
If sp.Count > 0 Then sr.Shapes(i).LeftX = sp(sp.Count).LeftX + sp(sp.Count).SizeWidth + index.jianju
sp.Add sr.Shapes(i)
Next
c = c + 1
Wend
EndOpt
End Sub
Sub zuo()‘---------------------------------------------------------------
On Error Resume Next
BeginOpt "11"
Dim OL As Integer '原始对象最左值
OL = 2300
Dim c As Integer '对象计数器
c = 0
Dim sp As ShapeRange
Dim sh As Shape, sr As ShapeRange
Set sr = ActiveSelectionRange
sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
While sr.Shapes.Count > c
Set sh = sr.Shapes(FindLeftShap())
If OL > sh.LeftX Then OL = sh.LeftX
Set sp = New ShapeRange
Dim i As Integer
For i = 1 To sr.Shapes.Count
'获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
sr.Shapes(i).LeftX = sh.LeftX '与最左一个对象左边对齐
If sp.Count > 0 Then sr.Shapes(i).TopY = sp(sp.Count).TopY - sp(sp.Count).SizeHeight - index.jianju
sp.Add sr.Shapes(i)
Next
c = c + 1
Wend
EndOpt
End Sub
Sub shang()‘---------------------------------------------------
BeginOpt "33"
Dim OL As Integer '原始对象最左值
OL = 2300
Dim c As Integer '对象计数器
c = 0
Dim sp As ShapeRange
Dim s As Shape, sr As ShapeRange
Set sr = ActiveSelectionRange
sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
While sr.Shapes.Count > c
Set s = sr.Shapes(FindLeftShap())
If OL > s.LeftX Then OL = s.LeftX
Set sp = New ShapeRange
Dim i As Integer
For i = 1 To sr.Shapes.Count
'获取高于最左边的一个对象的底部，但低于最左边对象的顶部的对象
sr.Shapes(i).TopY = s.TopY '与最左一个对象底部对齐
If sp.Count > 0 Then sr.Shapes(i).LeftX = sp(sp.Count).LeftX + sp(sp.Count).SizeWidth + index.jianju
sp.Add sr.Shapes(i)
Next
c = c + 1
Wend
EndOpt
End Sub
Sub you()’----------------------------------------------------------------------
BeginOpt "44"
Dim OL As Integer '原始对象最左值
OL = 2300
Dim c As Integer '对象计数器
c = 0
Dim sp As ShapeRange
Dim s As Shape, sr As ShapeRange
Set sr = ActiveSelectionRange
sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
While sr.Shapes.Count > c
Set s = sr.Shapes(FindLeftShap())
If OL > s.LeftX Then OL = s.LeftX
Set sp = New ShapeRange
Dim i As Integer
For i = 1 To sr.Shapes.Count
sr.Shapes(i).RightX = s.RightX '与最左一个对象左边对齐
If sp.Count > 0 Then sr.Shapes(i).TopY = sp(sp.Count).TopY - sp(sp.Count).SizeHeight - index.jianju
sp.Add sr.Shapes(i)
Next
c = c + 1
Wend
EndOpt
End Sub
垂直居中对齐，水平居中对齐，垂直均匀分布，水平均匀分布用这几个快捷键还不够吗？我觉得系统自带的快捷对齐已经够用了
页:
[1]