• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Text Boxes - How to populate them without overlapping, bumping in to each other

D

D Coker

Member
I have a bunch of code below that basically plots shapes on a chart with connectors to text boxes to be used as labels for the shapes onto a chart (Thanks to Chandoo.org experts!!)

Basically, the question is "Can code be added to this procedure or add a procedure that will check all text boxes and align them off of each other automatically so that they do not overlap with each other or any other shape?"

Photo added with labels adjusted for context.

81376




Code: 
 Sub Plot_ILI_Features()


Dim response As String
 Dim ldrlines As Boolean
 ldrlines = False
 
  response = MsgBox("Would you like leader lines from the label to indication?." & vbNewLine & vbNewLine _
        & "", vbYesNoCancel)
  If response = vbCancel Then
  Exit Sub
  End If
  If response = vbYes Then
  ldrlines = True
  If response = vbNo Then
  End If
  End If

'Get chart properties

Dim pl As Double
Dim pw As Double
Dim pt As Double
Dim ph As Double

Dim wsChart As Worksheet
Dim wsData As Worksheet

Dim oChObj As ChartObject

Set wsData = Sheets("Corr. Table")
Set wsChart = Sheets("Indication Map")
Const Pi As Double = 3.141592654
On Error GoTo eh

wsChart.Activate

Dim axmin As Double, axmax As Double

axmin = wsChart.Range("inspstart")
axmax = wsChart.Range("inspend")

'Get chart size/location
With wsChart
  pl = Range("E11").Left '- 7.5                            'Left zero ref from left
  pw = Range("O10").Left - Range("E34").Left '- 5       'Length of plot area
  pt = Range("E11").Top '- 1.5                             'Top zero ref of plot area
  ph = Range("O34").Top - Range("E10").Top '+ 2        'Height of plot area
End With

If axmax - axmin < 1 Then
MsgBox ("Verify Assessment Area Start and End in Master Page")
GoTo eh
End If


'Loop through Range
Dim lr As Long
lr = wsData.Range("C" & Rows.Count).End(xlUp).row

If lr < 7 Then
MsgBox ("Verify Correlation Table has ILI calls listed from Form F or Form G.")
GoTo eh
End If


Dim i As Integer
Dim PipeDia As Double
Dim ol As Double, ot As Double
Dim ow As Double, oh    As Double
Dim onm As String, ccode As String
Dim width As Double

PipeDia = Range("Nominal_Pipe_Diameter").Value2


  If PipeDia = 0 Then
  MsgBox ("Check Pipe Diameter in Master Page")
  GoTo eh
  End If
 
For i = 7 To lr 'Row 7 is first row of data
  'Get data for each Rectangle
  ccode = "ILI"
  ol = wsData.Cells(i, 24)                          'axial distance from start
  ot = wsData.Cells(i, 29)                          'clock position
  ow = wsData.Cells(i, 34)                          'length
  width = wsData.Cells(i, 38)
  
  
   'Creates minimum size for rectangle to be visible
  If width < 0.5 Then
  width = 1
  End If
 
  If ow < 0.5 Then 'length
  ow = 1
  End If
 
 
  oh = 720 * (width / (PipeDia * Pi)) 'width converted to mins
  onm = "ILI" + Format(wsData.Cells(i, 3), "-#") 'text box name
 
  'Corrects clock for 12:00 to 1:00
  If ot >= 0.5 Then
  ot = ot - 0.5
  End If
    
  'Process Rect location/size
  Dim shl As Double, Sht As Double, shw As Double, shh As Double
    
  shl = pl + pw * (ol - axmin) / (axmax - axmin)   'box axial start
 
 'If sht >
  Sht = pt + ot * ph / 0.5                         'box circ start
  shw = pw * ow / ((axmax - axmin) * 12)           'box width
  shh = ph * oh / (12 * 60)                        'box height
   'MsgBox ("Clock pos = " & ot)
   'MsgBox (sht)
  
  ' Adjust to edges of Plot Area
    Dim PlotOverlap As Boolean
  PlotOverlap = True 'True allows overlap, False stops overlap
 
  If Not PlotOverlap Then
    'check left edge
    If shl < pl Then
      shl = pl
      shw = shw - (pl - (pl + pw * (ol - axmin) / (axmax - axmin)))
    End If
    'check Right edge
    If shl + shw > pl + pw Then
      shw = pl + pw - shl
    End If
  End If

  'Setup Color Fill settings
  Dim mycolor As Double
  mycolor = Range("colorcode").Find(ccode, , , xlWhole).Interior.Color
    
    
  Dim DrawOutLine  As Boolean
  DrawOutLine = True 'Draw Rectangle Outline ?

  'Add Rectangle
  Dim plotwrap As Boolean
 
  plotwrap = True 'True allows Vertical Wrap, False stops Vertical Wrap
 
  Dim s1, s2, s3, t1, t2, t3 As Shape
  Dim conn1, conn2, conn3 As Shape
  Dim sht_Offset As Double
 
  If plotwrap And (Sht + shh) > (pt + ph) Then 'If Rectangle plots across 12:00
      'plot bottom of Rectangle
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, Sht - 4.5, shw, pt + ph - Sht).Select
      'Color Bottom half of Rectangle
      Call ColorShape(mycolor, DrawOutLine)
      Set s1 = ActiveSheet.Shapes(Selection.Name)
    '  MsgBox ("Circ Start: " & sht)
      'plot top of Rectangle
      Application.CutCopyMode = False
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, pt, shw, shh - (pt + ph - Sht)).Select
      'MsgBox (sht)
      Set s2 = ActiveSheet.Shapes(Selection.Name)
  Else
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, Sht, shw, shh).Select
      'MsgBox (sht)
      Set s3 = ActiveSheet.Shapes(Selection.Name)
  End If
    
  'Color Rectangle
  Call ColorShape(mycolor, DrawOutLine)
    
    If plotwrap And (Sht + shh) > (pt + ph) Then
  'Add text box for bottom rectangle
  sht_Offset = 15 'Offset from top of Rectangle
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, shl, ph - pt + 2, shw, shh - (pt + ph - Sht)).Select
  With Selection.ShapeRange.TextFrame2
     .VerticalAnchor = msoAnchorMiddle
    .MarginLeft = 0
    .MarginRight = 0
    .MarginTop = 0
    .MarginBottom = 0
    .WordWrap = False
    .AutoSize = msoAutoSizeShapeToFitText
    .TextRange.Characters.Text = onm
  End With
 
  Selection.ShapeRange.Line.Visible = msoTrue 'Plot Textbox border
  Selection.ShapeRange.Fill.Visible = msoFalse
 
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).ParagraphFormat
    .FirstLineIndent = 0
    .Alignment = msoAlignLeft ' Change Text alignment here
  End With
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).Font
    .NameComplexScript = "+mn-cs"
    .NameFarEast = "+mn-ea"
    .Size = 8 'Text size
    .Name = "+mn-lt"
  End With
  If ldrlines = True Then
 
    Set t1 = ActiveSheet.Shapes(Selection.Name)
    Set conn1 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)
    ' Connect shapes
   conn1.ConnectorFormat.BeginConnect s2, 1
   conn1.ConnectorFormat.EndConnect t1, 1
    conn1.Line.ForeColor.RGB = RGB(128, 128, 128)
    ' Connect via shortest path (changes connection sites)
    conn1.RerouteConnections
  'Add text box for top rectangle
  End If
 
  sht_Offset = 15 'Offset from top of Rectangle
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, shl, Sht - 12, shw, pt + ph - Sht).Select
  With Selection.ShapeRange.TextFrame2
    .VerticalAnchor = msoAnchorMiddle
    .MarginLeft = 0
    .MarginRight = 0
    .MarginTop = 0
    .MarginBottom = 0
    .WordWrap = False
    .AutoSize = msoAutoSizeShapeToFitText
    .TextRange.Characters.Text = onm
  End With

  Selection.ShapeRange.Line.Visible = msoTrue 'Plot Textbox border
  Selection.ShapeRange.Fill.Visible = msoFalse

  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).ParagraphFormat
    .FirstLineIndent = 0
    .Alignment = msoAlignLeft ' Change Text alignment here
  End With
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).Font
    .NameComplexScript = "+mn-cs"
    .NameFarEast = "+mn-ea"
    .Size = 8 'Text size
    .Name = "+mn-lt"
  End With
   If ldrlines = True Then
   Set t2 = ActiveSheet.Shapes(Selection.Name)

   Set conn2 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)
   ' Connect shapes
    conn2.ConnectorFormat.BeginConnect t2, 1
    conn2.ConnectorFormat.EndConnect s1, 1
    conn2.Line.ForeColor.RGB = RGB(128, 128, 128)
    ' Connect via shortest path (changes connection sites)
    conn2.RerouteConnections
   End If
Else
  sht_Offset = 15 'Offset from top of Rectangle
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, shl, Sht - sht_Offset, shw, 20).Select
  With Selection.ShapeRange.TextFrame2
    .VerticalAnchor = msoAnchorMiddle
    .MarginLeft = 0
    .MarginRight = 0
    .MarginTop = 0
    .MarginBottom = 0
    .WordWrap = False
    .AutoSize = msoAutoSizeShapeToFitText
    .TextRange.Characters.Text = onm
  End With

  Selection.ShapeRange.Line.Visible = msoTrue 'Plot Textbox border
  Selection.ShapeRange.Fill.Visible = msoFalse

  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).ParagraphFormat
    .FirstLineIndent = 0
    .Alignment = msoAlignLeft ' Change Text alignment here
  End With
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).Font
    .NameComplexScript = "+mn-cs"
    .NameFarEast = "+mn-ea"
    .Size = 8 'Text size
    .Name = "+mn-lt"
  End With
If ldrlines = True Then
  Set t3 = ActiveSheet.Shapes(Selection.Name)
  Set conn3 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)
    ' Connect shapes
    conn3.ConnectorFormat.BeginConnect s3, 1
    conn3.ConnectorFormat.EndConnect t3, 1
    conn3.Line.ForeColor.RGB = RGB(128, 128, 128)
    ' Connect via shortest path (changes connection sites)
    conn3.RerouteConnections
  End If
  End If
  

Next i

'Bring all Textboxes to Front

Dim oTextBox As TextBox

For Each oTextBox In ActiveSheet.TextBoxes
  If Left(oTextBox.Name, 4) = "Text" Then
    oTextBox.Select
    Selection.ShapeRange.ZOrder msoBringToFront
  '  Selection.ShapeRange.Fill.Visible = msoCTrue
  End If
Next oTextBox

Range("A1").Select

eh:

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
As always, the key to writing a program is working out the process first. After that, writing the code for it is usually pretty straightforward. I can get about halfway through this one; maybe someone can figure out the other half.

First, definitions: You're talking about moving not the colored boxes in the graphic you included, just the labels, right? And when you say you want to "align them off each other", I'm guessing that you mean not just that they mustn't overlap each other, but that ideally they should be lined up in a column, one above the other. looking rather like rows in a worksheet.

To do this part, it seems to me you need a program that finds all the text boxes and goes through them adding up their height (which will presumably be all the same) and finding the one with the greatest width. That identifies the height and width of a rectangle that can contain all the text boxes.

Then your program has to identify a place in the graphic where a rectangle of those dimensions can be placed without overlapping any of the colored boxes. I don't know how that would work; maybe you can figure that out, or someone else here can.

After that, putting all the text boxes into that area should be a snap.

About the lines that point from each label to its appropriate box, I don't know how that works either.
 
BobBridges said:
As always, the key to writing a program is working out the process first. After that, writing the code for it is usually pretty straightforward. I can get about halfway through this one; maybe someone can figure out the other half.

First, definitions: You're talking about moving not the colored boxes in the graphic you included, just the labels, right? And when you say you want to "align them off each other", I'm guessing that you mean not just that they mustn't overlap each other, but that ideally they should be lined up in a column, one above the other. looking rather like rows in a worksheet.

To do this part, it seems to me you need a program that finds all the text boxes and goes through them adding up their height (which will presumably be all the same) and finding the one with the greatest width. That identifies the height and width of a rectangle that can contain all the text boxes.

Then your program has to identify a place in the graphic where a rectangle of those dimensions can be placed without overlapping any of the colored boxes. I don't know how that would work; maybe you can figure that out, or someone else here can.

After that, putting all the text boxes into that area should be a snap.

About the lines that point from each label to its appropriate box, I don't know how that works either.
Click to expand...

This is a chart, so the text boxes do not have to be in alignment. The leader lines are automated, so that avoids confusion as to which text box and rectanglular shape are paired.

The main idea is to simply keep the text boxes (just the labels) from overlapping.
 
Hm. I can see how I'd go about deciding the location of each of a bunch of rectangles that are all to fit into a pattern such as I describe above. But if their current sizes and locations are more or less random, it isn't clear to me how I'd proceed. I mean, I suppose the program could go through all the rectangles one at a time and for each one search out a random location that wouldn't interfere with the others—but I'm sure the result would be visually chaotic without an organizing principle behind it. I don't think that'd be any help.
 
Not sure if a collection is a good approach.
I thought if I could collect all the .Top and .Left positions along with the .Height and .width for all text boxes, I could store them in a collection.
From there, test each text box to see if thier position is within any of the other positions in the collection, then loop movement until they are no longer within another's position. I am unsure how to test if the positions are within a range of values within the collection.

Only the labels/text boxes would be moved. The rectangles are precisely positioned and cannot be moved.

Code: 
Sub textboxplacement()
 Dim C As New Collection 'Rectangles
 Dim TBC As New Collection 'Text Boxes[ATTACH type="full" alt="82384"]82384[/ATTACH]
  Dim TB As TextBox
  Dim S As Shape
  Dim Item
  Dim TItem
 
  'Collect all text boxes
 
  ReDim TItem(0 To 4)
  For Each TB In ActiveSheet.TextBoxes
    If Left(TB.Name, 4) = "Text" Then
      'Store the shape name
      TItem(0) = TB.Name
      'Save the properties
      TItem(1) = TB.Top
      TItem(2) = TB.Left
      TItem(3) = TB.Top + TB.Height
      TItem(4) = TB.Left + TB.width
 
      'Store the items into the collection
      TBC.Add TItem
    End If
  Next
  
   ReDim Item(0 To 4)
    For Each S In ActiveSheet.Shapes
    If Left(S.Name, 4) = "Rect" Then
      'Store the shape name
      Item(0) = S.Name
      'Save the properties
      Item(1) = S.Top
      Item(2) = S.Left
      Item(3) = S.Top + S.Height
      Item(4) = S.Left + S.width

      'Store the items into the collection
      C.Add Item
    End If
  Next
 
  'Check Text Box Info
  '  For Each TItem In TBC
   ' MsgBox TItem(0) & " " & TItem(1) & " " & TItem(2) & " " & TItem(3) & " " & TItem(4)
'Next
'Check Rectangle Info
  ' For Each Item In C
 '   MsgBox Item(0) & " " & Item(1) & " " & Item(2) ' & " " & Item(3) & " " & Item(4)
'Next


For Each TB In ActiveSheet.TextBoxes
    If Left(TB.Name, 4) = "Text" Then
      'Store the shape name
     ' TItem(0) = TB.Name
      'Save the properties
  If TB.Top < Item(1) Then
     TB.Top = TB.Top - 1
     TB.Left = TB.Left - 1
      'TItem(2) = TB.Left
     ' TItem(3) = TB.Top + TB.Height
     ' TItem(4) = TB.Left + TB.width
 End If
 
   If TB.Top > Item(1) Then
     TB.Top = TB.Top + 1
     TB.Left = TB.Left + 1
      'TItem(2) = TB.Left
     ' TItem(3) = TB.Top + TB.Height
     ' TItem(4) = TB.Left + TB.width
 End If
      'Store the array into the collection
    '  TBC.Add TItem
    End If
  Next

End Sub
 

Attachments

  • AnotherExample.PNG
    AnotherExample.PNG
    125.4 KB · Views: 6
...And it just occurred to me that it's quite possible to have a situation where there is no solution, that is, that some boxes will overlap no matter where you put them—and I have no idea how I would teach a program to recognize that situation.
 
How about looping through a set of data and determine if the current item is within a range of each previous items? In the attached example photo, I have the data. I want to check the following:

If TextBox 24.Top is between TextBox 7.Top and TextBox 7.Bottom OR if TextBox 24.Left is between TextBox 7.Left and TextBox 7.Right. Check if either is true and return true.

Loop to the next TextBox

If TextBox 27.Top is between TextBox. 24.Top and TextBox 24.Bottom OR if TextBox 27.Left is between TextBox 24.Left and TextBox 24.Right
OR TextBox 27.Top is between TextBox.7.Top and TextBox7.Bottom OR if TextBox27.Left is between TextBox7.Left and TextBox7.Right. Check if any is true and return true.

Loop to the next TextBox


I am trying to get the IF/OR statement to grow so that each range of values from the current text box are checked against all previous text box values. Thanks for reading.


Example Data.PNG
 
Disregarding the table above, I was able to hash out a very sloppy macro that will atleast move the the text boxes off each other, I just can't seem to get the loop to work effectively without putting in a counter. I cant state the correct condition to keep the loop going to infinite.


Code: 
Sub MoveOverlappingTextBoxes()
    Dim ws As Worksheet
    Dim tb As Shape
    Dim i As Integer
    Dim j As Integer
    Dim tb2 As Shape
    Dim k As Long


k = 0

    Set ws = ActiveSheet
Do While k < 33000                                                                                  'need help here!!!!
    For i = 1 To ws.Shapes.Count
        Set tb = ws.Shapes(i)
        If tb.Type = msoTextBox Then
            For j = i + 1 To ws.Shapes.Count
                Set tb2 = ws.Shapes(j)
                If tb2.Type = msoTextBox Then
                    If tb2.Type = msoTextBox And tb.Name <> tb2.Name Then
                 
                    If Not (tb.Top > tb2.Top + tb2.Height Or _
                    tb.Left > tb2.Left + tb2.width Or _
                    tb.Top + tb.Height < tb2.Top Or _
                    tb.Left + tb.width < tb2.Left) Then
                        tb.Top = tb.Top + tb2.Height + 5
                        tb.Left = tb.Left + tb2.width + 5
                        tb2.Top = tb2.Top - tb.Height - 5
                        tb2.Left = tb2.Left - tb.width - 5
                        k = k + 1
                       
                        Else
                   
                        k = k + 1
                        End If
                       
                     
                   
                    End If
                End If
            Next j
        End If
    Next i
    Loop

End Sub
 
The Do Loop and K variable seem to help.

No macro used to aid in correcting overlap.
82453


Macro without Do Loop
82454




Macro with Do Loop

82455
 
So bad logic … Revise your strategy on a paper as to check objects coordinates no need such useless 'infinite' additional loop …​
​
 
I would if I knew how. That's why I have posted on the forum for guidance....not vague responses.
 
Last edited by a moderator:
So elaborate at least with details your strategy - be accurate - in order there is nothing to guess …​
​
As a reminder :​

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...
chandoo.org
 
Many logic errors in your post #8 code :​
  1. the first loop must end before the last shape aka Shapes.Count - 1

  2. Before the second loop you forgot to calculate the master shape coordinates (according to variable i) with the margin around it

  3. Inside the second loop the If statement must compare the shape coordinates (according to variable j)
    versus the master shape margin coordinates and when necessary
    change only the coordinates of the shape without modifying the master shape.
Any additional loop like the one using the variable k just means the logic fails somewhere …​
​
 
This code seems to work fairly well. I am unsure how to improve upon it.
Code: 
Sub MoveOverlappingTextBoxes()
    Dim ws As Worksheet
    Dim tb As Shape
    Dim i As Integer
    Dim j As Integer
    Dim tb2 As Shape
Dim overlap As Boolean

Application.ScreenUpdating = False
Application.StatusBar = "Please be patient while loading"



    Set ws = Sheets("Indication Map")
  Do
  overlap = False
    For i = 1 To ws.Shapes.Count
        Set tb = ws.Shapes(i)
        If tb.Type = msoTextBox Then
            For j = i + 1 To ws.Shapes.Count
                Set tb2 = ws.Shapes(j)
                If tb2.Type = msoTextBox Then
                    If tb2.Type = msoTextBox And tb.Name <> tb2.Name Then
                
                    If Not (tb.Top > tb2.Top + tb2.Height Or _
                    tb.Left > tb2.Left + tb2.width Or _
                    tb.Top + tb.Height < tb2.Top Or _
                    tb.Left + tb.width < tb2.Left) Then
                    
                    
                        tb.Top = tb.Top + tb2.Height + 1
                        tb.Left = tb.Left + tb2.width + 1
                        tb2.Top = tb2.Top - tb.Height - 1
                        tb2.Left = tb2.Left - tb.width - 1
                        overlap = True
                    
                        
                      
                        End If
                        
                       'check going off chart to the right
                      If tb.Left + tb.width > Range("O1").Left Then
                                tb.Left = tb.Left - tb.width - 5
                      End If
                       'check going off chart to the left
                      If tb.Left < Range("E1").Left Then
                                tb.Left = Range("E1").Left
                      End If
                       'check going off chart to the right
                      If tb2.Left + tb2.width > Range("O1").Left Then
                                tb2.Left = tb2.Left - tb2.width - 5
                      End If
                       'check going off chart to the left
                      If tb2.Left < Range("E1").Left Then
                                tb2.Left = Range("E1").Left
                      End If
                        'check going off chart to the bottom
                      If tb.Top + tb.Height > Range("A35").Top Then
                                tb.Top = Range("A35").Top - tb.Height
                      End If
                       'check going off chart to the top
                      If tb.Top < Range("A11").Top Then
                                tb.Top = Range("A11").Top
                      End If
                       'check going off chart to the bottom
                      If tb2.Top + tb2.Height > Range("A35").Top Then
                                tb2.Top = Range("A35").Top - tb2.Height
                      End If
                       'check going off chart to the top
                      If tb2.Top + tb2.Height < Range("A11").Top Then
                                tb2.Top = Range("A11").Top - tb2.Height
                      End If
                                            
                                            
                    End If
                
                End If
            Next j
        End If
    Next i
    Loop Until overlap = False
    Application.ScreenUpdating = True
End Sub
 
Release each object variable before to end the procedure​
or use directly the worksheet CodeName rather than creating a duplicate variable object reference​
or just using directly a With - End With block …​
​
 
You must log in or register to reply here.
Back
Top