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.)


SpaceCamel wrote:
>
> 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,

--

Dave Peterson

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/mic...985fefb3dc65bb

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

"SpaceCamel" <(E-Mail Removed)> wrote in message
news:52244C2A-5F52-4E11-8997-(E-Mail Removed)...
> 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,

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



"SpaceCamel" <(E-Mail Removed)> wrote in message
news:52244C2A-5F52-4E11-8997-(E-Mail Removed)...
> 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,

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

"SpaceCamel" <(E-Mail Removed)> wrote in message
news:52244C2A-5F52-4E11-8997-(E-Mail Removed)...
> 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,

Oops. I just skipped over that part about being in the same cell.

NickHK wrote:
>
> 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/mic...985fefb3dc65bb
>
> 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
>
> "SpaceCamel" <(E-Mail Removed)> wrote in message
> news:52244C2A-5F52-4E11-8997-(E-Mail Removed)...
> > 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,

--

Dave Peterson

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

Regards,
Peter T

Great! Thanks guys.

I think I have enough to adapt for my situation.


"Peter T" wrote:

> 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
>
> "SpaceCamel" <(E-Mail Removed)> wrote in message
> news:52244C2A-5F52-4E11-8997-(E-Mail Removed)...
> > 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,
>
>
>