detect shape overlap?

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I am automatically creating shapes within cells on a sheet but do not want
them overlaping. I do not know how many there will be within each cell.

Is the a way to determine if a new shape will overlap an existing one so it
can be shifted down out of the way?

Thanks,
 
Each shape has a .topleftcell and a .bottomrightcell property.

Maybe you can use that to determine where to put the next picture--or you could
look at each shape to see if any cell is shared between the two ranges:

Dim myShape1 as shape
dim myShape2 as shape
dim Rng1 as range
dim Rng2 as range

with worksheets("Sheet9999")
set myshape1 = .shapes(1)
set myshape2 = .shapes(2)

set rng1 = .range(myshape1.topleftcell,myshape1.bottomrightcell)
set rng2 = .range(myshape2.topleftcell,myshape2.bottomrightcell)

if intersect(rng1, rng2) is nothing then
'nothing in common
else
'do what you want
end if
end with

(Untested, uncompiled--watch for typos.)
 
Dave has offered one solution. However, you say all the shapes will be in
the same cell (although shapes are not IN a cell, they are on a layer above
the cells).
As such, Dave's approach won't work

Assuming the shapes are rectangular or using their bounding box is
sufficient, you test for overlap with this function recently posted on
microsoft.public.vb.general.discussion:
http://groups.google.co.uk/group/mi...ne+for+you+rick&rnum=1&hl=en#7b985fefb3dc65bb

Note, this is valid code, but not that clear. Read the whole thread to
understand it's meaning and simplify your own code:

Public Function RangesOverlapAmount(ByVal RangeA1 As Long, _
ByVal RangeA2 As Long, _
ByVal RangeB1 As Long, _
ByVal RangeB2 As Long) As Long
RangesOverlapAmount = Format((RangeA2 + RangeB2 - RangeA1 - _
RangeB1 - Abs(RangeA2 - RangeB2) - _
Abs(RangeA1 - RangeB1)) / 2, "0;\0")
End Function

If you have non-rectangular shapes that you have to test for overlap, a more
complex approach will be required, whereby the geometry of each shape is
taking into account.

NickHK
 
Another one just for fun -

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

Sub RandomShapes()
Dim i&, x#, y#
ActiveSheet.Rectangles.Delete
For i = 1 To 50
x = Rnd() * 300
y = Rnd() * 200
' ActiveSheet.Shapes.AddShape 1, x, y, 90, 60
ActiveSheet.Rectangles.Add x, y, 90, 60
Next
End Sub

Sub Unjumble()
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
GetCoordinates shps(i), B
For j = 1 To i - 1
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
If Abs(A.xl - B.xl) > Abs(A.yt - B.yt) Then
B.yt = A.yb + minGap: shps(i).Top = B.yt
Else
B.xl = A.xr + minGap: shps(i).Left = B.xl
End If
End If
bH = False: bV = False
Next
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

This could be adapted as a function to move only the last (top) shape and/or
return suggested left/top.

Regards,
Peter T
 
Another one just for fun -

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
End Sub

Sub UnJumble()
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
GetCoordinates shps(i), B
For j = 1 To i - 1
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
If Abs(A.xl - B.xl) > Abs(A.yt - B.yt) Then
B.yt = A.yb + minGap: shps(i).Top = B.yt
Else
B.xl = A.xr + minGap: shps(i).Left = B.xl
End If
End If
bH = False: bV = False
Next
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

This could be adapted as a function to move only the last (top) shape and/or
return suggested left/top.

Regards,
Peter T
 
Sorry about the two posts, made a small last minute change but can't think
how the first post got sent.

Regards,
Peter T
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

searching for text within shapes 3
Change Shapes (countries in map) based on conditions 1
Shape Arrays VBA 0
Changing the test of checkboxes (shapes) programmatically? 3
Create shape, name shape, add text to shape 2
Shapes in 2010 1
shape objects, displaying text, extra info?? 3
Finding name of shape that was last clicked - Application.Caller 5

Back
Top