All,

I've developed an application that essentially takes information within a table, and generates a number of textbox call-outs based upon the information within the table. The code below moves all overlapping shapes so they're no longer overlapping (works quite well). However, i'd like to also ensure that no shapes are covering a pre-defined (and static) range (collection of cells). Let's say i'd want to make sure no shapes overlap Range("E17:H30") of the activesheet. Any ideas here?

Many thanks in advance!




Option Explicit
Type CO_ORDS
    xl As Single
    xr As Single
    yt As Single
    yb As Single
End Type

Sub RandomShapes()
    Dim i As Long
    ActiveSheet.Rectangles.Delete
    For i = 1 To 20
        ActiveSheet.Rectangles.Add Rnd() * 300, _
        Rnd() * 200, _
        Rnd() * 90 + 30, _
        Rnd() * 90 + 20
    Next i
End Sub

Sub UnJumbleCallOut()
    Dim bH As Boolean, bV As Boolean, bRedo As Boolean
    Dim A As CO_ORDS, B As CO_ORDS
    Dim minGap As Single
    Dim i As Long, j As Long, nCnt As Long
    Dim shps As Shapes
    
    minGap = 3
    If minGap < 0.75 Then minGap = 0.75
    
    Set shps = ActiveSheet.Shapes
    
    bRedo = True
    Do Until bRedo = False
        bRedo = False
        For i = 2 To shps.Count
            'added to only test for callout box
            If InStr(1, shps(i).Name, "risk_callout") > 0 Then
                'gets the coord for shape i into B
                GetCoordinates shps(i), B
                For j = 1 To i - 1
                    'added to only test for callout box
                    If InStr(1, shps(j).Name, "risk_callout") > 0 Then
                        'gets the coord for shape j into A
                        GetCoordinates shps(j), A
                        bH = (B.xl >= A.xl And B.xl <= A.xr) Or (A.xl >= B.xl And A.xl <= B.xr)
                        bV = (B.yt >= A.yt And B.yt <= A.yb) Or (A.yt >= B.yt And A.yt <= B.yb)
                        If bH And bV Then
                            bRedo = True
                            'this is the code determinine which direction to move the shape
                            If Abs(A.xl - B.xl) < Abs(A.yt - B.yt) Then
                                'moves i down
'                                B.yt = A.yb + minGap
'                                shps(i).Top = B.yt
                                shps(i).Top = ((A.yb + B.yt) / 2) + minGap
                                shps(j).Top = A.yt - ((A.yb - A.yt) / 2)
                            Else
                                'moves i right
'                                B.xl = A.xr + minGap
'                                shps(i).Left = B.xl
                                shps(i).Left = ((A.xr + B.xl) / 2) + minGap
                                shps(j).Left = A.xl - ((A.xr - A.xl) / 2)
                            End If
                        End If
                    End If
                bH = False: bV = False
                Next
            End If
        Next
    Loop
End Sub

Function GetCoordinates(Sh As Shape, pos As CO_ORDS)
    With Sh
        pos.xl = .Left
        pos.xr = pos.xl + .Width
        pos.yt = .Top
        pos.yb = pos.yt + .Height
    End With
End Function