Crossposting VBA Question - Overlapping Text Boxes with all Shapes

[Coker]

I have included links below where I asked other forums for guidance. Thanks in advance!


https://www.mrexcel.com/board/thread...other.1221142/

https://chandoo.org/forum/threads/te...29/post-292014

[Aussiebear]

Your question as it should have been asked here... rather than asking others to relocate their interests.

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?"

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?." , 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

[Coker]

My apologies. I am fairly new to these forums so I wasn't sure how to cross post correctly while maintaining compliance with the forums.

[Aussiebear]

That's okay. You will find that "not cross posting" is a fairly common rule in all forums, so for your benefit please go to read the forum rules before posting in any forum.

[Coker]

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.

Sub textboxplacement() Dim C As New Collection 'Rectangles
 Dim TBC As New Collection 'Text Boxes
  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