Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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, |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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.bottomrightce ll) set rng2 = .range(myshape2.topleftcell,myshape2.bottomrightce ll) 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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" wrote in message ... 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, |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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" wrote in message ... 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, |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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" wrote in message ... 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, |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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" wrote in message ... 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
Sorry about the two posts, made a small last minute change but can't think
how the first post got sent. Regards, Peter T |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
detect shape overlap?
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" wrote in message ... 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, |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
my curser changed from arrow shape to a cross shape???? | New Users to Excel | |||
Detect which shape was clicked.... | Excel Programming | |||
Detect which shape was clicked? | Excel Programming | |||
Deleting a shape and the cell contents the shape is in. | Excel Programming | |||
Deleting a shape and the cell contents the shape is in. | Excel Programming |