对附近的形状进行分组

Question

我有两个彼此靠近的形状，其中一个被选中。我需要能够将它与所选形状组合在一起。

感谢您的帮助！

这是我附带的代码，但它似乎与附近的形状不匹配。特别是它没有找到一个 20ptx20pt 的矩形，它向左偏移大约一半，向顶部偏移一半高度：

Option Explicit
Sub Test()
Dim oSl As slide
Dim oSh As Shape
Dim oSh2 As Shape
    
Dim MainHeight As Long
Dim MainWidth As Long

MainHeight = 48.76
MainWidth = 88.45
    
    
Set oSl = Application.ActiveWindow.View.slide
Set oSh = ActiveWindow.Selection.ShapeRange(1)

        For Each oSh2 In oSl.Shapes
            If IsWithinRangey(oSh, oSh2, 0.4) Then
                oSh2.Select (False)
            End If
        Next
''        ActiveWindow.Selection.ShapeRange.Group
    
End Sub

Function IsWithinRangey(oSh As Shape, oSh2 As Shape, _
    AreaTolerance As Single) As Boolean
' Is the shape within the coordinates supplied?

    Dim WidthMin As Single
    Dim WidthMax As Single
    Dim HeightMin As Single
    Dim HeightMax As Single

    With oSh
    
        HeightMin = oSh.Height * (1 - AreaTolerance)
        HeightMax = oSh.Height * (1 + AreaTolerance)
        WidthMin = oSh.Width * (1 - AreaTolerance)
        WidthMax = oSh.Width * (1 + AreaTolerance)
    
        Debug.Print "==========================="
        Debug.Print "Shp: " & .Width & " x " & .Height
        Debug.Print "Min: " & WidthMin & " x " & HeightMin
        Debug.Print "Max: " & WidthMax & " x " & HeightMax
    End With

       
   With oSh2
   
        If oSh.Id <> oSh2.Id Then
            ShapeLeft = oSh.Left - (19.85) / 1
            ShapeTop = oSh.Top - (19.85) / 1
            
            Debug.Print ShapeLeft
            Debug.Print ShapeTop
            
            
            If .Left >= ShapeLeft And .Left < ShapeLeft + WidthMax Then
                If .Top >= ShapeTop And .Top < ShapeTop + HeightMax Then
                    If .Width >= WidthMin And .Width <= WidthMax Then
                        If .Height > HeightMin And .Height < HeightMax Then
                            IsWithinRangey = True
                    End If
                    End If
                End If
            End If
        End If
    End With

End Function

Answer 1

为了让你的代码更有效率，我会重组如下：

Dim WidthMin As Single
Dim WidthMax As Single
Dim HeightMin As Single
Dim HeightMax As Single

Sub GroupCloseShapes()
    Dim oSl As Slide
    Dim oSh As Shape
    Dim oSh2 As Shape
    Dim MainHeight As Long
    Dim MainWidth As Long

    MainHeight = 48.76
    MainWidth = 88.45

    Set oSl = Application.ActiveWindow.View.Slide
    Set oSh = ActiveWindow.Selection.ShapeRange(1)

    With oSh
        HeightMin = oSh.Height * (1 - AreaTolerance)
        HeightMax = oSh.Height * (1 + AreaTolerance)
        WidthMin = oSh.Width * (1 - AreaTolerance)
        WidthMax = oSh.Width * (1 + AreaTolerance)
    End With
    
    For Each oSh2 In oSl.Shapes
        If oSh.ID <> oSh2.ID Then
            If IsWithinRangey(oSh, oSh2, 0.4) Then
                oSh2.Select (False)
            End If
        End If
    Next
'' ActiveWindow.Selection.ShapeRange.Group
End Sub

Function IsWithinRangey(oSh As Shape, oSh2 As Shape, AreaTolerance As Single) As Boolean ' Is the shape within the coordinates supplied?
    With oSh2
        .Select
        ShapeLeft = oSh.Left - (19.85) / 1
        ShapeTop = oSh.Top - (19.85) / 1
        Debug.Print ShapeLeft
        Debug.Print ShapeTop
        If .Left >= ShapeLeft And .Left < ShapeLeft + WidthMax Then
            If .Top >= ShapeTop And .Top < ShapeTop + HeightMax Then
                If .Width >= WidthMin And .Width <= WidthMax Then
                    If .Height > HeightMin And .Height < HeightMax Then
                        IsWithinRangey = True
                End If
                End If
            End If
        End If
    End With
End Function

我添加了 .Select 方法来明确当前正在检查哪个形状。您的问题与 IsWithinRangey 函数中的数学计算有关。要调试它们，请单击代码左侧的灰色条。这将插入一个断点：

运行宏。它会在断点处停止。按 F8 单步执行每个语句。将鼠标悬停在变量名称上以查看它们的当前值。然后调整你的计算以找到你想要的形状并忽略你不想要的形状。

Answer 2

感谢@JohnKorchok！最终代码如下

Option Explicit

Dim WidthMax As Single
Dim HeightMax As Single
Dim ShapeLeft As Single
Dim ShapeTop As Single
Dim AreaTolerance As Single
Dim StepNumberWidth As Single
Dim StepNumberHeight As Single
Dim oNewShape As Shape


Sub GroupCloseShapes()
    Dim oSl As Slide
    Dim oSh As Shape
    Dim oSh2 As Shape
    Dim MainHeight As Long
    Dim MainWidth As Long

    MainHeight = 48.76
    MainWidth = 88.45
    StepNumberWidth = 19.85
    StepNumberHeight = 19.85
    
    Set oSl = Application.ActiveWindow.View.Slide
    Set oSh = ActiveWindow.Selection.ShapeRange(1)

    With oSh
        HeightMax = oSh.Height * (1 + AreaTolerance)
        WidthMax = oSh.Width * (1 + AreaTolerance)
        ShapeLeft = oSh.Left - StepNumberWidth / 1
        ShapeTop = oSh.Top - StepNumberHeight / 1
        
    End With
    
    For Each oSh2 In oSl.Shapes
        If oSh.Id <> oSh2.Id Then
            If IsWithinRangey(oSh, oSh2, 0.4) Then
                oSh2.Select (False)
            End If
        End If
    Next
'' ActiveWindow.Selection.ShapeRange.Group
End Sub

Function IsWithinRangey(oSh As Shape, oSh2 As Shape, AreaTolerance As Single) As Boolean ' Is the shape within the coordinates supplied?
    With oSh2
        If .Left >= ShapeLeft And .Left <= ShapeLeft + WidthMax Then
            If .Top >= ShapeTop And .Top <= ShapeTop + HeightMax Then
                If .Width <= WidthMax Then
                    If .Height <= HeightMax Then
                        IsWithinRangey = True
                    End If
                End If
            End If
        End If
    End With
End Function

对附近的形状进行分组

Grouping nearby shapes

powerpoint

vba