Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → Получение границ многострочного атрибута
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Здравствуйте!
Подскажите, как узнать прямоугольник, в который вписан многострочный текст?
For Each varAtr In Block.GetAttributes
If varAtr.TagString = "Tag" Then
varAtr.GetBoundingBox startPoint, endPoint
End If
NextGetBoundingBox выдает, насколько я понимаю, прямоугольник аналогичного текста, но в одну строку...
Никто не делал подобное?
Может, можно развалить текст на строки, потом собрать?
Как у тебя обявлены переменные startPoint, endPoint
Должны быть вариант
Переменные - вариант, координаты получаются.
НО! Если нарисовать полученные точки, то они образуют не ограничивающий прямоугольник, а что-то другое. Как я понимаю - прямоугольник с высотой, равной высоте строки текста данного шрифта и с длиной, равной длине этого текста, написанного в одну строку.
Переменные - вариант, координаты получаются.
НО! Если нарисовать полученные точки, то они образуют не ограничивающий прямоугольник, а что-то другое. Как я понимаю - прямоугольник с высотой, равной высоте строки текста данного шрифта и с длиной, равной длине этого текста, написанного в одну строку.
Вот тебе костыль в виде лиспа, по-другому можно с использованием класса VLAX.cs
- ищи сам по форумам
Код модуля (измени имя лисп файла "C:/Test/setwh.lsp" на то где сохранишь)
Option Explicit
Const lspfile As String = "C:/Test/setwh.lsp" '!<--- change lisp file name here !
Sub aab()
Dim obj As Object
Dim pp As Variant, mat As Variant, ctx As Variant
ThisDrawing.Utility.GetSubEntity obj, pp, mat, ctx, vbCrLf & "Select multiline attribute >> "
Dim att As AcadAttributeReference
Set att = obj
Dim txt As String
txt = att.TextString
Dim pmin As Variant
Dim pmax As Variant
Dim hdl As String
hdl = att.handle
ThisDrawing.SetVariable "users1", hdl
ThisDrawing.SendCommand "(load " & Chr(34) & lspfile & Chr(34) & ") "
ThisDrawing.SendCommand "(princ)" & vbCr
ThisDrawing.SendCommand "(setwh " & Chr(34) & hdl & Chr(34) & ") " & vbCr
Dim wid As Double
wid = CDbl(ThisDrawing.GetVariable("userr1"))
Dim hgt As Double
hgt = CDbl(ThisDrawing.GetVariable("userr2"))
Dim th As Double
th = att.Height
Dim p As Variant
p = att.InsertionPoint
p = ThisDrawing.Utility.TranslateCoordinates(p, acUCS, acWorld, False)
'change frame points relative to attribute Alignment property:
Dim pts(7) As Double
pts(0) = CDbl(p(0)) - th: pts(1) = CDbl(p(1)) + th
pts(2) = CDbl(p(0)) + wid + th: pts(3) = CDbl(p(1)) + th
pts(4) = CDbl(p(0)) + wid + th: pts(5) = CDbl(p(1)) - hgt - th
pts(6) = CDbl(p(0)) - th: pts(7) = CDbl(p(1)) - hgt - th
Dim pline As AcadLWPolyline
Set pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts) 'ors
pline.Closed = True
pline.color = acCyan
pline.Lineweight = 40
End SubКод лиспа, сохрани где хочешь
В блокноте вставь следующий код
;;****************************************** (defun setwh(handle) (setq en (handent (getvar "users1"))) (setq elist (entget en)) (setq wid (cdr (assoc 42 elist))) (setq hgt (cdr (assoc 43 elist))) (setvar "userr1" wid) (setvar "userr2" hgt) (princ)) ;;*******************************************
Сохрани обязательно под именем setwh.lsp
в любой своей папке, но не забудь потом этот же путь
прописать в модуле
Отлично, попробую! Спасибо! Получается, из VB эти значения
(setq wid (cdr (assoc 42 elist)))
(setq hgt (cdr (assoc 43 elist)))
никаким образом не выдернуть?
А разве у атрибута нет свойства GeometricExtents?
По идее (без проверок) что-то типа того должно быть (это в C#, но смысл - главное):
Extents3d ext = varAtr.GeometricExtents; Point3d maxPt = ext.MaxPoint; Point3d minPt = ext.MinPoint;
В том-то и дело... В ObjectARX вроде такое есть, а в vbs (а нужен именно vbs) этого метода нету...
А разве у атрибута нет свойства GeometricExtents?
По идее (без проверок) что-то типа того должно быть (это в C#, но смысл - главное):
Код
Extents3d ext = varAtr.GeometricExtents;
Point3d maxPt = ext.MaxPoint;
Point3d minPt = ext.MinPoint;
Кстати, попробуй сам, увидишь интересный результат, гарантирую,
напр. в 2010-й
Проверил, работает. Правда, нужно вычисления чуть поменять.
Возникла такая проблема: файл лиспа гружу вручную, потом использую следующий код:
Dim hdl As String
hdl = varAtr.Handle
ThisDrawing.SetVariable "users1", hdl
ThisDrawing.SendCommand "(setwh " & Chr(34) & hdl & Chr(34) & ") " & vbCr
Dim wid As Double
wid = CDbl(ThisDrawing.GetVariable("userr1"))
Dim hgt As Double
hgt = CDbl(ThisDrawing.GetVariable("userr2"))
И на второй раз вместо команды setwh запускается какая-то другая и код перестает работать до перезапуска autocad. С чем это может быть связано?
Попробуй добавить
ThisDrawing.SendCommand "(setwh " & Chr(34) & hdl & Chr(34) & ")" & vbCr ThisDrawing.SendCommand "(princ)"
Не помогает :(
Вообще, ощущение, что он не успевает что-то сделать.
До этого запускал команду с брейкпоинтом на строчке с SendCommand, если запустить без него - тоже часто вылетает ошибка.
---
Хммм сейчас сработало с первого раза, упало на третий О.о Бред какой-то
Кстати там я не лишний пробел случайно добавил в команде загрузки лиспа?
ThisDrawing.SendCommand "(setwh " & Chr(34) & hdl & Chr(34) & ") " & vbCr
И еще можно попробовать такой трюк:
после клика по атрибуту создавать лидер или мультилидер с рамкой програмно
а длину лидера выстаылять в ноль (видел такую идею на форумах)
Не пробовал....
Не помогает
Вообще, ощущение, что он не успевает что-то сделать.
До этого запускал команду с брейкпоинтом на строчке с SendCommand, если запустить без него - тоже часто вылетает ошибка.---
Хммм сейчас сработало с первого раза, упало на третий О.о Бред какой-то
Кароч придется по-видимому обычным методом,
правда неаккуратненько как-то
Option Explicit
Sub MFrame()
Dim obj As Object
Dim pp As Variant, mat As Variant, ctx As Variant
ThisDrawing.Utility.GetSubEntity obj, pp, mat, ctx, vbCrLf & "Select multiline attribute >> "
Dim att As AcadAttributeReference
Set att = obj
If Not att.MTextAttribute Then
MsgBox "You have to select MULTILINE attribute only"
Exit Sub
End If
Dim txt As String
txt = att.TextString
'' Get the longest string line of Mtext
Dim x() As String
x = Split(att.MTextAttributeContent, "\P")
Dim n As Integer
n = UBound(x)
Dim wmax As Integer
wmax = Len(x(0))
Dim i
For i = 1 To UBound(x)
If Len(x(i)) > wmax Then
wmax = Len(x(i))
End If
Next i
Dim hgt As Double
Dim th As Double
hgt = att.Height * n + att.Height * (n - 1) * 0.625
Dim p As Variant
p = att.InsertionPoint
att.MTextBoundaryWidth = wmax * att.Height * 0.5
Dim wid As Double
wid = wmax * att.Height * 0.625
p = ThisDrawing.Utility.TranslateCoordinates(p, acUCS, acWorld, False)
'change frame points relative to attribute Alignment property:
Dim gap As Double
gap = att.Height
Dim pts(7) As Double
pts(0) = CDbl(p(0)) - gap: pts(1) = CDbl(p(1)) + gap
pts(2) = CDbl(p(0)) + wid + gap: pts(3) = CDbl(p(1)) + gap
pts(4) = CDbl(p(0)) + wid + gap: pts(5) = CDbl(p(1)) - hgt - gap
pts(6) = CDbl(p(0)) - gap: pts(7) = CDbl(p(1)) - hgt - gap
Dim pline As AcadLWPolyline
Set pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts)
pline.Closed = True
pline.color = acYellow
pline.Lineweight = 40
End SubСтраницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Получение границ многострочного атрибута
Форум работает на PunBB, при поддержке Informer Technologies, Inc
