有没有VB大佬帮我优化下代码
Public Sub 按面积从大到小底面对齐()Dim s As Shape, sr As ShapeRange
Dim i As Long, j As Long
Dim areaArray() As Double
Dim shapeArray() As Shape
Dim tempArea As Double
Dim tempShape As Shape
Dim xPos As Double
Dim minY As Double
Dim spacing As Double
ActiveDocument.Unit = cdrMillimeter
' 设置间距为20mm（转换为文档单位）
spacing = 20
' 检查是否有选中的对象
If ActiveSelection.Shapes.Count = 0 Then
MsgBox "请先选择要排序的对象!", vbExclamation
Exit Sub
End If
' 初始化数组
ReDim areaArray(1 To ActiveSelection.Shapes.Count)
ReDim shapeArray(1 To ActiveSelection.Shapes.Count)
' 获取选中的对象和它们的面积
i = 1
For Each s In ActiveSelection.Shapes
shapeArray(i) = s
areaArray(i) = s.SizeWidth * s.SizeHeight ' 计算面积（宽×高）
i = i + 1
Next s
' 使用冒泡排序按面积从大到小排序
For i = 1 To UBound(areaArray) - 1
For j = i + 1 To UBound(areaArray)
If areaArray(i) < areaArray(j) Then
' 交换面积
tempArea = areaArray(i)
areaArray(i) = areaArray(j)
areaArray(j) = tempArea
' 交换形状
Set tempShape = shapeArray(i)
Set shapeArray(i) = shapeArray(j)
Set shapeArray(j) = tempShape
End If
Next j
Next i
' 创建新的ShapeRange
Set sr = ActiveDocument.CreateShapeRange
' 将排序后的形状添加到ShapeRange中
For i = 1 To UBound(shapeArray)
sr.Add shapeArray(i)
Next i
' 找出所有形状的最低点（用于底部对齐）
minY = shapeArray(1).PositionY - shapeArray(1).SizeHeight / 2
For i = 2 To UBound(shapeArray)
If (shapeArray(i).PositionY - shapeArray(i).SizeHeight / 2) < minY Then
minY = shapeArray(i).PositionY - shapeArray(i).SizeHeight / 2
End If
Next i
' 排列形状（底部对齐，水平排列）
xPos = shapeArray(1).PositionX - shapeArray(1).SizeWidth / 2 ' 起始X位置
For i = 1 To UBound(shapeArray)
' 设置底部对齐
shapeArray(i).PositionY = minY + shapeArray(i).SizeHeight / 2
' 设置水平位置
If i > 1 Then
xPos = xPos + shapeArray(i - 1).SizeWidth / 2 + spacing + shapeArray(i).SizeWidth / 2
Else
xPos = xPos + shapeArray(i).SizeWidth / 2
End If
shapeArray(i).PositionX = xPos
Next i
End Sub
直接用deepseek 或 chatgpt优化就可以了
chunhui0712 发表于 2025-4-10 10:56
直接用deepseek 或 chatgpt优化就可以了
用了不行deepseek 本帖最后由 Aweiwei 于 2025-4-10 15:36 编辑
用chatgpt4o这个应该可以，https://claud.top/pastel#/carlist用微软邮箱或者谷歌注册个账号试用几次应该能搞定，不行就换个邮箱再注册一个 Sub 排列()
Dim sr As shapeRange
Dim Cnt As Integer
Dim baseY As Double
Dim startX As Double
Set sr = ActiveSelectionRange
If sr.Count = 0 Then Exit Sub
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrBottomLeft
sr.Sort "@shape1.width*@shape1.height>@shape2.width*@shape2.height"
baseY = sr(1).BottomY
For Cnt = 2 To sr.Count
If sr(Cnt).BottomY < baseY Then
baseY = sr(Cnt).BottomY
End If
Next Cnt
startX = sr(1).LeftX
sr(1).SetPosition startX, baseY
For Cnt = 2 To sr.Count
sr(Cnt).SetPosition sr(Cnt - 1).RightX + 100, baseY
Next Cnt
End Sub dlh 发表于 2025-4-11 08:27
Sub 排列()
Dim sr As shapeRange
Dim Cnt As Integer
太感谢了:hug::hug::hug:
dlh 发表于 2025-4-11 08:27
Sub 排列()
Dim sr As shapeRange
Dim Cnt As Integer
大佬 这个代码能增加个自动换行的功能么？有些文件图形太多超出界限都堆积在一起了 现在的人工智能太厉害了。 dlh 发表于 2025-4-11 08:27
Sub 排列()
Dim sr As shapeRange
Dim Cnt As Integer
根据大佬的代码让AI 帮忙增加了自动换行的功能
Sub ArrangeShapes()
Dim sr As ShapeRange
Dim shp As Shape
Dim Cnt As Integer
Dim baseY As Double, currentX As Double, rowHeight As Double, maxWidth As Double
Set sr = ActiveSelectionRange
If sr.Count = 0 Then Exit Sub
With ActiveDocument
.Unit = cdrMillimeter
.ReferencePoint = cdrBottomLeft
End With
sr.Sort "@shape1.width*@shape1.height>@shape2.width*@shape2.height"
baseY = 1E+99
For Each shp In sr
If shp.BottomY < baseY Then baseY = shp.BottomY
Next shp
currentX = sr(1).LeftX
rowHeight = 0
maxWidth = ActivePage.SizeWidth - 100
For Cnt = 1 To sr.Count
Set shp = sr(Cnt)
If currentX + shp.SizeWidth > maxWidth Then
baseY = baseY - rowHeight - 100
currentX = sr(1).LeftX
rowHeight = 0
End If
shp.SetPosition currentX, baseY
currentX = currentX + shp.SizeWidth + 100
If shp.SizeHeight > rowHeight Then rowHeight = shp.SizeHeight
Next Cnt
End Sub
页:
[1]