有没有VB大佬帮我优化下代码

A-Ming

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

chunhui0712

直接用deepseek 或 chatgpt优化就可以了

A-Ming

chunhui0712 发表于 2025-4-10 10:56
直接用deepseek 或 chatgpt优化就可以了

用了不行deepseek

Aweiwei

用chatgpt4o这个应该可以，https://claud.top/pastel#/carlist  用微软邮箱或者谷歌注册个账号试用几次应该能搞定，不行就换个邮箱再注册一个

dlh

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

A-Ming

dlh 发表于 2025-4-11 08:27
Sub 排列()
    Dim sr As shapeRange
    Dim Cnt As Integer

太感谢了

xiaoshenren

dlh 发表于 2025-4-11 08:27
Sub 排列()
    Dim sr As shapeRange
    Dim Cnt As Integer

大佬 这个代码能增加个自动换行的功能么  ？有些文件图形太多  超出界限  都堆积在一起了

linro

现在的人工智能太厉害了。

xiaoshenren

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