Question

我搜索了一个宏，它会将所有选定的形状调整为与最小的选定形状相同的高度和宽度，但没有任何运气。我找到了以下代码，它成功地将所有选定的形状调整为与最大选定形状相同的高度和宽度。我想如果我简单地颠倒每个“＆gt;”和“＆lt;”s那么代码就能满足我的需要，但它不起作用。无论最小选择形状的大小如何，它都会将所有内容调整为.01“x.01”。有人会介意让我知道我需要在下面的代码中调整什么吗？为格式化提前道歉 - 第一篇文章。

Sub resizeAll()
    Dim w As Double
    Dim h As Double
    Dim obj As Shape

    w = 0
    h = 0

    ' Loop through all objects selected to assign the biggest width and height to w and h
    For i = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set obj = ActiveWindow.Selection.ShapeRange(i)
        If obj.Width > w Then
            w = obj.Width
        End If

        If obj.Height > h Then
            h = obj.Height
        End If
    Next

    ' Loop through all objects selected to resize them if their height or width is smaller than h/w
    For i = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set obj = ActiveWindow.Selection.ShapeRange(i)
        If obj.Width < w Then
            obj.Width = w
        End If

        If obj.Height < h Then
            obj.Height = h
        End If
    Next
End Sub

Answer 1

请改为尝试：

Sub ResizeToSmallest()
    ' PPT coordinates are Singles rather than Doubles
    Dim sngNewWidth As Single
    Dim sngNewHeight As Single
    Dim oSh As Shape

    ' Start with the height/width of first shape in selection
    With ActiveWindow.Selection.ShapeRange
        sngNewWidth = .Item(1).Width
        sngNewHeight = .Item(1).Height
    End With

    ' First find the smallest shape in the selection
    For Each oSh In ActiveWindow.Selection.ShapeRange
        If oSh.Width < sngNewWidth Then
            sngNewWidth = oSh.Width
        End If
        If oSh.Height < sngNewHeight Then
            sngNewHeight = oSh.Height
        End If
    Next

    ' now that we know the height/width of smallest shape
    For Each oSh In ActiveWindow.Selection.ShapeRange
        oSh.Width = sngNewWidth
        oSh.Height = sngNewHeight
    Next

End Sub

请注意，这会扭曲形状或导致宽度调整为不同的大小，以便根据形状的.LockAspectRatio设置保持形状的宽高比。

Answer 2

Sub ImageSizeToShortest()
    Dim sAspectRatio As Single, i As Integer, r As Range, h As Single
    h = Selection.PageSetup.PageHeight
    Set r = Selection.Range
    With ActiveDocument
        For i = 1 To .Shapes.count
            .Shapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                If h > .Shapes(i).Height Then h = .Shapes(i).Height
            End If
        Next i
        For i = 1 To .InlineShapes.count
            .InlineShapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                If h > .InlineShapes(i).Height Then h = .InlineShapes(i).Height
            End If
        Next i
        For i = 1 To .Shapes.count
            .Shapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                sAspectRatio = .Shapes(i).Width / .Shapes(i).Height
                .Shapes(i).Height = h
                .Shapes(i).Width = .Shapes(i).Height * sAspectRatio
            End If
        Next i
        For i = 1 To .InlineShapes.count
            .InlineShapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                sAspectRatio = .InlineShapes(i).Width / .InlineShapes(i).Height
                .InlineShapes(i).Height = h
                .InlineShapes(i).Width = .InlineShapes(i).Height * sAspectRatio
            End If
        Next i
    End With
    r.Select
End Sub

调整所选形状的最小形状

2 个答案: