Search the Community

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