Create a Rectangle around Text

I want to resolve this problem.

 

Here is the problem. I create a program for increase the size of text, Text.Height

 

Now the text sometimes intersect with other objects, when this append I take the Text.Insertion point and move a little up, down, left, right, and review with command intersectwith if the object text intersect with other object on drawing.

 

But some times the Intersectwith give me a False intersection, for example if I have a text with 6.13 degree of rotation the program give me a intersection with text 767R2654-1052FC-2

 

A false intersection, The autocad create a BoundingBox around text but this box not considerer the text rotation, the box is not on angle of rotation like a box create with QTEXT command, I need a Box like QTEXT, but Qtext is imposible to get and use for intersectwith. Maybe a polyline like a QText box.

 

Now I need a box around the text for review if the text intersect with the yellow polyline. I need to do this for 7894 dxf drawings, I have a list of dxf drawings and path and autocad open file by file automatic and increse size and move the text with intersection but the problem is the false intersection. So I need a code for create a rectangle around the text, I try the command Qtext but I can't get the rectangle, I try to create Text.GetBoundingBox (MinPnt, MaxPnt) the result is a box on (0,0).

 

My both Function Code

Private Function Intersecta(Texto As AcadObject) As Boolean

'Dim Entidades() As AcadObject

Dim Entidades() As AcadEntity

Dim InsPntTexto As Variant, InsPntEntidades() As Variant

Dim BETA As Variant

Dim y As Integer, w As Integer

For y = 0 To ThisDrawing.Blocks.Count - 1

For w = 0 To ThisDrawing.Blocks.Item(y).Count - 1

'ReDim Entidades(2)

ReDim Entidades(1)

'ReDim InsPntEntidades(0)

ReDim InsPntEntidades(2)

On Error Resume Next

Set Entidades(1) = ThisDrawing.Blocks.Item(y).Item(w)

InsPntTexto = Texto.InsertionPoint

BETA = Entidades(1).InsertionPoint

InsPntEntidades(0) = BETA(0): InsPntEntidades(1) = BETA(1): InsPntEntidades(2) = BETA(2)

'InsPntEntidades = Entidades(1).InsertionPoint

If InsPntTexto(0) = InsPntEntidades(0) And InsPntTexto(1) = InsPntEntidades(1) And Entidades(1).EntityName = "AcDbText" Then

GoTo amonos

Else

If (IntersectWith(Texto, Entidades(1))) = True Then

'MsgBox "intersecta"

Wrksheet.Cells(RowCount, 9) = "X: " & Entidades(1).EntityName

Intersecta = True

Exit Function

Else

Intersecta = False

End If

End If

amonos:

Next w

Next y

End Function

Public Function IntersectWith(Object1 As AcadEntity, Object2 As AcadEntity) As Boolean

Dim Intersection As Variant

Intersection = Object1.IntersectWith(Object2, AcExtendOption.acExtendNone)

If UBound(Intersection) = -1 Then

IntersectWith = False

Else

IntersectWith = True

End If

End Function

 

Thanks for your help.

 

Code for Text Movement

 

Private Sub Change_Size()

Dim Texto As AcadObject

Dim i As Integer

Dim z As Integer

For i = 0 To ThisDrawing.Blocks.Count - 1

For z = 0 To ThisDrawing.Blocks.Item(i).Count - 1

On Error Resume Next

Set Texto = ThisDrawing.Blocks.Item(i).Item(z)

If Texto.EntityName = "AcDbText" Then

If UCase(Trim(Texto.TextString)) Like "*BK*" Or UCase(Trim(Texto.TextString)) Like "*FC*" Then

Wrksheet.Cells(RowCount, 5) = Texto.Height

ThisDrawing.Blocks.Item(i).Item(z).Height = 0.26

ThisDrawing.Regen acAllViewports

If Intersecta(Texto) = True Then Movimientos i, z

Wrksheet.Cells(RowCount, 6) = ThisDrawing.Blocks.Item(i).Item(z).Height

Wrksheet.Cells(RowCount, 7) = Texto.TextString

If Wrksheet.Cells(RowCount, 10) = "Imposible Correct" Then

Alfa = False

Else

Alfa = True

End If

End If

End If

If Err 0 Then Err.Clear

Next z

Next i

End Sub

 

 

Public Sub Movimientos(i As Integer, z As Integer)

Dim Intersect As Boolean

Dim TextObjPoint As Variant

Dim ObjectUnknowPoint As Variant

Dim Rotation As Variant

Dim pi As Variant

Dim Correccion As Boolean

Dim Texto As AcadObject

pi = 4 * Atn(1)

Set Texto = ThisDrawing.Blocks.Item(i).Item(z)

If Texto.EntityName = "AcDbText" Then

If UCase(Trim(Texto.TextString)) Like "*FC*" Or UCase(Trim(Texto.TextString)) Like "*BK*" Then 'Izquierda

'****************************** CORRECCION DE POSICION ************************

TextObjPoint = Texto.InsertionPoint

ptn = Texto.InsertionPoint

Rotation = Texto.Rotation

ThisDrawing.Regen acAllViewports

'Izquierda

TextObjPoint(0) = TextObjPoint(0) + (0.4 * ((2 * Cos(Rotation - pi))))

TextObjPoint(1) = TextObjPoint(1) + (0.4 * ((2 * Sin(Rotation - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Derecha

TextObjPoint(0) = TextObjPoint(0) - (0.4 * ((2 * Cos(Rotation - pi))))

TextObjPoint(1) = TextObjPoint(1) - (0.4 * ((2 * Sin(Rotation - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

Application.ZoomExtents

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then '**** Abajo

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Abajo

TextObjPoint(0) = TextObjPoint(0) + (0.2 * ((2 * Sin(Rotation - pi))))

TextObjPoint(1) = TextObjPoint(1) + (0.2 * ((2 * Cos(Rotation - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then ' ***** Arriba

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

' Arriba

TextObjPoint(0) = TextObjPoint(0) - (0.2 * ((2 * Sin(Rotation - pi))))

TextObjPoint(1) = TextObjPoint(1) - (0.2 * ((2 * Cos(Rotation - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then ' ***** Abajo Derecha

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Abajo Derecha

TextObjPoint(0) = TextObjPoint(0) - (0.2 * ((2 * Cos(Rotation - 45 - pi))))

TextObjPoint(1) = TextObjPoint(1) - (0.2 * ((2 * Sin(Rotation - 45 - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(Texto) = True Then ' ***** Abajo Izquierda

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Abajo Izquierda

TextObjPoint(0) = TextObjPoint(0) + (0.2 * ((2 * Cos(Rotation + 45 - pi))))

TextObjPoint(1) = TextObjPoint(1) + (0.2 * ((2 * Sin(Rotation + 45 - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then ' ***** Arriba Derecha

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Arriba Derecha

TextObjPoint(0) = TextObjPoint(0) - (0.2 * ((2 * Sin(Rotation + 45 - pi))))

TextObjPoint(1) = TextObjPoint(1) - (0.2 * ((2 * Cos(Rotation + 45 - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

If Intersecta(Texto) = True Then ' ***** Arriba Izquierda

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

'Arriba Izquierda

TextObjPoint(0) = TextObjPoint(0) + (0.2 * ((2 * Sin(Rotation - 45 - pi))))

TextObjPoint(1) = TextObjPoint(1) + (0.2 * ((2 * Cos(Rotation - 45 - pi))))

Texto.InsertionPoint = TextObjPoint

ThisDrawing.Regen acAllViewports

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Arriba Izquierda

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Arriba Derecha

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Abajo Izquierda

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Abajo Derecha

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Arriba

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Abajo

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If '**** Derecha

Else

Wrksheet.Cells(RowCount, 10) = "OK RW"

Alfa = True

GoTo Vamonos

End If 'FC & BK Izquierda

End If 'AcDbText

If Intersecta(ThisDrawing.Blocks.Item(i).Item(z)) = True Then 'Corrección Imposible

Texto.InsertionPoint = ptn

TextObjPoint = Texto.InsertionPoint

ThisDrawing.Regen acAllViewports

Wrksheet.Cells(RowCount, 10) = "Imposible Correct"

Application.ZoomExtents

End If

Vamonos:

End Sub

Perhaps this:

Angle = Text.Rotation

Set the Text’s Rotation property to 0.

Get BoundingBox.

Create LWPoly from the min and max.

Reset Text.Rotation = Angle.

Rotate the LWPoly, BasePoint = Text. TextAlignmentPoint, RotationAngle = Angle

Use LWPoly with IntersectWith

Thanks for your help, you are rigth.

 

This is a very easy solution ;-)

 

Eng. Zeus Alberto Páez Rentería

 

Perhaps this:

 

Angle = Text.Rotation

Set the Text’s Rotation property to 0.

Get BoundingBox.

Create LWPoly from the min and max.

Reset Text.Rotation = Angle.

Rotate the LWPoly, BasePoint = Text. TextAlignmentPoint, RotationAngle = Angle

Use LWPoly with IntersectWith

Cool that it all worked out.