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/threads/text-boxes-how-to-populate-them-without-overlapping-bumping-in-to-each-other.1221142/

https://chandoo.org/forum/threads/text-boxes-how-to-populate-them-without-overlapping-bumping-in-to-each-other.49429/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

https://chandoo.org/forum/data/attachments/81/81468-3a49553f212269ebdcaec2e9cf8bb484.jpg

[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