| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA. Как получить значения объекта Text зная его координаты.

VBA. Как получить значения объекта Text зная его координаты.

Ответ
Поиск в этой теме
Непрочитано 20.09.2021, 21:49 #1
VBA. Как получить значения объекта Text зная его координаты.
zZombie
 
инженер проектировщик
 
Мск
Регистрация: 26.10.2020
Сообщений: 7

Так же известно имя слоя на котором находиться Text. Слой заморожен, если это имеет значение.

Вообще хочу вытащить макросом информацию из файла ТактГаза о диаметрах труб и сохранить ее в этом же файле в более читабильном виде. Может кто то заморачивался?

----- добавлено через ~22 мин. -----
SelectAtPoint?
Просмотров: 1075
 
Непрочитано 20.09.2021, 22:30
#2
Boxa

КЖ; C#
 
Регистрация: 03.11.2005
Санкт-Петербург
Сообщений: 2,459


а не проще перебрать объекты модели, фильтруя тексты и сравнивая координаты... просто select имеет ограничения - объект должен быть виден на экране
__________________
_бложиг
Boxa вне форума  
 
Непрочитано 21.09.2021, 00:20
#3
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 9,457


в самом простейшем случае:
1. Получить select с фильтром объекты AcadText на указанном слое.
2. В цикле по полученному набору у каждого текстового примитива получать методом GetBoundingBox координаты границ описывающего прямоугольника, и проверять вхождение точки в данный прямоугольник.
Сергей812 вне форума  
 
Непрочитано 21.09.2021, 03:55
#4
Автон

СЦБ
 
Регистрация: 09.03.2006
Иркутск
Сообщений: 60


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
в самом простейшем случае:
1. Получить select с фильтром объекты AcadText на указанном слое.
2. В цикле по полученному набору у каждого текстового примитива получать методом GetBoundingBox координаты границ описывающего прямоугольника, и проверять вхождение точки в данный прямоугольник.

Код:
[Выделить все]
Function FindText_(X, Y As Double, LayerName As String) As String

  Dim ssetObj As AcadSelectionSet
  Dim mode As Integer
  Dim groupCode As Variant, dataCode As Variant
  Dim minExt As Variant
  Dim maxExt As Variant
  Dim gpCode(1) As Integer
  Dim dataValue(1) As Variant
  
  FindText_ = ""
  
  For i = 0 To ThisDrawing.SelectionSets.Count - 1
      If ThisDrawing.SelectionSets.Item(i).Name = "SSET" Then ThisDrawing.SelectionSets.Item(i).Delete
  Next i
  
  Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
  mode = acSelectionSetAll
 
  gpCode(0) = 0
  dataValue(0) = "*TEXT"
  gpCode(1) = 8
  dataValue(1) = LayerName 'Имя слоя
  groupCode = gpCode
  dataCode = dataValue

  ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
   
  For Each Object In ssetObj
          Object.GetBoundingBox minExt, maxExt
          If minExt(0) < X And maxExt(0) > X And minExt(1) < Y And maxExt(1) > Y Then
              FindText_ = Object.TextString
              Exit For
          End If
  Next
End Function

Вызов
MsgBox FindText_(1841.9, 1396.9, "Слой1")
Автон вне форума  
 
Автор темы   Непрочитано 21.09.2021, 11:57
#5
zZombie

инженер проектировщик
 
Регистрация: 26.10.2020
Мск
Сообщений: 7


Хм. Применение select изменяет предварительный выбор обрабатываемых объектов.
Давайте я выложу файл. Иначе я на словах не смогу объяснить.
Приложил служебный файл программы "ТактГаз". В нем для расчетов хранится информация о установке газового пожаротушения. В [изначально] скрытом слое gazinf лежат данные, в которых закодирована информация о трубах. Трубы изображаются полилиниями.
Данные кодируются так (на примере для участка "2" трубы):

в координатах первой вершины полилинии лежит объект "TEXT" такого содержания

(462 148 "(2)1.95d73h1.95"))

где 462 148 - это координаты последней вершины полилинии (они же начало следующей полилинии) без дробных частей;
(2) - номер участка;
1.95 - длина участка трубы;
d73 - диаметр трубы;
h1.95 - перепад высот на этом участке трубы (подъем на 1.95м в данном случае).

Нужно вывести эту информацию в читабельном виде, под/слева от полилинии.

----- добавлено через ~4 мин. -----
Изначально хотел выбирать все полилинии и запускать макрос на VBA для обработки.
Но не соображу как получить объект ТЕКСТ что бы его обработать.
Наверное все таки нужно делать как Boxa подсказал.
Вложения
Тип файла: dwg
DWG 2013
13g-1.dwg (29.9 Кб, 8 просмотров)
zZombie вне форума  
 
Непрочитано 21.09.2021, 15:04
#6
LenidSN


 
Регистрация: 24.01.2018
Сообщений: 41


Код:
[Выделить все]
 Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
--------------------------------------------------------------
 Dim TextCollection As Collection
  Dim aText As AcadText
  On Error Resume Next
  For Each aText In ssetObj
       TextCollection.Add aText
   Next
LenidSN вне форума  
 
Непрочитано 21.09.2021, 19:27
#7
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 9,457


ну примерно так для частного случая из пятого поста

Код:
[Выделить все]
Public Sub Hlop_Top()
  
  Const lNameSS As String = "GISS"
  Dim lAcadApp As AcadApplication
  Set lAcadApp = GetObject(, "AutoCAD.Application")
  Dim lCurrDoc As AcadDocument
  Set lCurrDoc = lAcadApp.ActiveDocument
  Dim lSS As AcadSelectionSet
  On Error Resume Next
  Set lSS = lCurrDoc.SelectionSets.Add(lNameSS)
  If (Err.Number <> 0) Then
    lCurrDoc.SelectionSets(lNameSS).Delete
    Set lSS = lCurrDoc.SelectionSets.Add(lNameSS)
  End If
  On Error GoTo 0
  Dim lGroupCodes(0 To 1) As Integer, lDataValues(0 To 1) As Variant
  lGroupCodes(0) = 0: lDataValues(0) = "TEXT"
  lGroupCodes(1) = 8: lDataValues(1) = "gazinf"
  lSS.Select acSelectionSetAll, , , CVar(lGroupCodes), CVar(lDataValues)
  If (lSS.Count = 0) Then
    MsgBox "Не найдено текстовых служебных объектов!", vbInformation + vbOKOnly
  Else
    Dim lInsertPoint(0 To 2) As Double, lIPV As Variant
    Dim I1 As Long, lMinExt As Variant, lMaxExt As Variant
    Dim lSourceText As AcadText, lDestText As AcadText, lText As String
    For I1 = 0 To lSS.Count - 1
      ' Получаем исходный текст
      Set lSourceText = lSS(I1)
      lText = lSourceText.TextString
      lIPV = lSourceText.InsertionPoint
      ' Преобразовываем исходный текст (ну тут просто в верхний регистр переведен)
      lText = UCase(lText)
      ' Добавляем новый текст в пространство модели
      Set lDestText = lCurrDoc.ModelSpace.AddText(lText, lIPV, 1.5)
      ' Высчитываем смещение точки вставки нового текста
      lDestText.GetBoundingBox lMinExt, lMaxExt
      lInsertPoint(0) = lIPV(0) - lMaxExt(0) + lMinExt(0) - 2
      lInsertPoint(1) = lIPV(1) - lMaxExt(1) + lMinExt(1) - 2
      ' Ну и корректируем точку вставки нового текста
      lDestText.InsertionPoint = lInsertPoint
    Next I1
  End If
  Set lSS = Nothing
  Set lCurrDoc = Nothing
  Set lAcadApp = Nothing
End Sub
код приведен для COM-интерфейса из экселя, но принцип не меняется. Только смотрю, программа небрежно служебные поля лепит в трубных узлах поверх друг друга, соответственно и новый текст тоже накладывается. Т.е. еще придется анализировать - не совпадают ли исходные тексты по точке вставки и тогда добавлять дополнительные смещения для новых текстов.
Сергей812 вне форума  
 
Автор темы   Непрочитано 21.09.2021, 23:16
#8
zZombie

инженер проектировщик
 
Регистрация: 26.10.2020
Мск
Сообщений: 7


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
Только смотрю, программа небрежно служебные поля лепит в трубных узлах поверх друг друга, соответственно и новый текст тоже накладывается.
я же говорю - этот текст находится в первой вершине полилинии означающей трубу. а так как из одной точки может начинаться две трубы (тройник), то соответственно служебный текст в таких местах начинается в одной точке для разных полилилиний.

Получается что то вроде этого:
Код:
[Выделить все]
Sub PLGetInfo()
    Dim ACADObject As AcadEntity
    Dim PLineHeadCoords As Variant
    Dim ResDataObj As DataObject
    Dim s As String
    Dim StartPnt(2) As Double
    Dim EndPnt(2) As Double
    Dim objSelCol As AcadSelectionSets
    Dim ssetObj As AcadSelectionSet
    Dim ssetObjPLs As AcadSelectionSet
    Dim intDXF(3) As Integer
    Dim varVal(3) As Variant
    Dim I As Integer
    Dim textObj As AcadText
    Dim THeight As Double
    Dim InsertionPoint(0 To 2) As Double
    
    Const SsetName1 = "PLsSet1"
    Const SsetName2 = "PLsSet2"
    
    Set ResDataObj = New DataObject
    
    Set objSelCol = ThisDrawing.SelectionSets
    N = objSelCol.Count - 1
    For I = 0 To N
        If objSelCol.Item(I).Name = SsetName1 Or objSelCol.Item(I).Name = SsetName2 Then
            objSelCol.Item(I).Delete
        End If
    Next
    ' Create the selection set
    Set ssetObj = ThisDrawing.SelectionSets.Add(SsetName1)
    Set ssetObjPLs = ThisDrawing.SelectionSets.Add(SsetName2)
    
    ReDim ssobjs(0) As AcadEntity
    
    I = 0
    For Each ACADObject In ThisDrawing.ActiveSelectionSet
        If ACADObject.ObjectName = "AcDbPolyline" Then
            ReDim Preserve ssobjs(I) As AcadEntity
            Set ssobjs(I) = ACADObject
            I = I + 1
        End If
    Next
    
    If I > 0 Then
        ssetObjPLs.AddItems ssobjs
    End If
    
    'On Error GoTo TERMINATION
    
    intDXF(0) = -4
    varVal(0) = "<AND"
    intDXF(1) = 8
    varVal(1) = "gazinf"
    intDXF(2) = 0
    varVal(2) = "*TEXT"
    intDXF(3) = -4
    varVal(3) = "AND>"

    For Each ACADObject In ssetObjPLs
    'For Each ACADObject In ThisDrawing.ActiveSelectionSet
        If ACADObject.ObjectName = "AcDbPolyline" Then
            PLineHeadCoords = ACADObject.Coordinates
            StartPnt(0) = PLineHeadCoords(0)                    ' начальная вершина ребра i
            StartPnt(1) = PLineHeadCoords(1)
            StartPnt(2) = 0#
            EndPnt(0) = PLineHeadCoords(UBound(PLineHeadCoords, 1) - 1) ' конечная вершина ребра i
            EndPnt(1) = PLineHeadCoords(UBound(PLineHeadCoords, 1) - 0)
            EndPnt(2) = 0#
            
            'ssetObj.Clear
            'ssetObj.SelectAtPoint StartPnt, intDXF, varVal
            'If ssetObj.Count > 0 Then
            '    If ssetObj.Item(0).ObjectName = "AcDbText" Then
             '       S = ssetObj.Item(0).TextString
              '      Debug.Print S
               ' End If
            'End If
            
            s = FindText_(StartPnt(0), StartPnt(1), EndPnt(0), EndPnt(1), "gazinf")
            Debug.Print s
            
            ' Define the text object
            THeight = 5#
            InsertionPoint(0) = Round(((StartPnt(0) + EndPnt(0)) / 2) - THeight * 1.1)
            InsertionPoint(1) = Round(((StartPnt(1) + EndPnt(1)) / 2))
            InsertionPoint(2) = 0#
            THeight = 5#
            
            ' Create the text object in model space
            Set textObj = ThisDrawing.ModelSpace.AddText(s, InsertionPoint, THeight)
            textObj.Layer = "0"
            
           
            textObj.Alignment = acAlignmentMiddleRight   ' шаг 1 !!!
            textObj.TextAlignmentPoint = InsertionPoint   ' шаг 2 !!!!
                      
            
            'DistToInt = Round(Sqr((StartPnt(0) - TempVar(0)) ^ 2 + (TempVar(1) - StartPnt(1)) ^ 2))
           
        End If
    Next
    
   
TERMINATION:
    ssetObj.Delete
    ssetObjPLs.Delete
End Sub
    

    
Function FindText_(X1, Y1, X2, Y2 As Double, LayerName As String) As String

  Dim ssetObj2 As AcadSelectionSet
  Dim mode As Integer
  Dim groupCode As Variant, dataCode As Variant
  Dim minExt As Variant
  Dim maxExt As Variant
  Dim gpCode(1) As Integer
  Dim dataValue(1) As Variant
  Dim sX2 As String
  Dim sY2 As String
  Dim s As String
  Dim p1, p2 As Long
  
  FindText_ = ""
  
  For I = 0 To ThisDrawing.SelectionSets.Count - 1
      If ThisDrawing.SelectionSets.Item(I).Name = "SSET" Then ThisDrawing.SelectionSets.Item(I).Delete
  Next I
  
  Set ssetObj2 = ThisDrawing.SelectionSets.Add("SSET")
  mode = acSelectionSetAll
 
  gpCode(0) = 0
  dataValue(0) = "*TEXT"
  gpCode(1) = 8
  dataValue(1) = LayerName '??? ????
  groupCode = gpCode
  dataCode = dataValue

  ssetObj2.Select acSelectionSetAll, , , groupCode, dataCode
   
  For Each Object In ssetObj2
    Object.GetBoundingBox minExt, maxExt
    If minExt(0) <= X1 And maxExt(0) > X1 And minExt(1) <= Y1 And maxExt(1) > Y1 Then
      s = Object.TextString
      p1 = InStr(s, " ")
      p2 = InStr(p1 + 1, s, " ")
      If p2 > p1 Then
        sX2 = Mid(s, 2, p1 - 2)
        sY2 = Mid(s, p1 + 1, p2 - p1 - 1)
        If (CInt(sX2) = CInt(Fix(X2))) And (CInt(sY2) = CInt(Fix(Y2))) Then
            'Debug.Print sX2
            ' (623 -33 "(7)1.6d0h1.6")
            s = Mid(s, InStr(p2 + 3, s, ")") + 1)
            s = Left(s, Len(s) - 2)
            's= "L="+
            'FindText_ = Object.TextString
            FindText_ = s
            Exit For
        End If
      End If
    End If
  Next
  
  ssetObj2.Delete
End Function
Спасибо за подсказки!

Последний раз редактировалось zZombie, 23.09.2021 в 22:09.
zZombie вне форума  
 
Непрочитано 22.09.2021, 07:34
#9
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 38,328


Может, стоит для таких целей использовать XData или словари? Всяко поустойчивее будет, КМК.
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.09.2021, 10:11
#10
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 9,457


Код:
[Выделить все]
If ACADObject.ObjectName = "AcDbPolyline" Then
            ReDim Preserve ssobjs(I) As AcadEntity
            Set ssobjs(I) = ACADObject
            I = I + 1
        End If
получаете постоянное перераспределение памяти при каждой иттерации цикла с нахождением полилинии. И почему просто коллекцию не взять?
Код:
[Выделить все]
Dim lPLs as new Collection
...
lPLs.Add ACADObject
...
lPLs.Count - количество выделенных полилиний.
И доступ к элементу коллекции
Код:
[Выделить все]
lPLs(Индекс)
Сергей812 вне форума  
 
Автор темы   Непрочитано 23.09.2021, 22:10
#11
zZombie

инженер проектировщик
 
Регистрация: 26.10.2020
Мск
Сообщений: 7


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
получаете постоянное перераспределение памяти при каждой иттерации цикла с нахождением полилинии. И почему просто коллекцию не взять?
да, Вы правы, с коллекциями будет правильней. Спасибо.
zZombie вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA. Как получить значения объекта Text зная его координаты.

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
AutoCad. Невозможно ввести определенное значение координаты положения объекта. Cfytrr AutoCAD 25 31.01.2019 20:01
Как просчитать координаты всего чертежа, зная координаты нескольких точек Barsum AutoCAD 6 16.02.2018 09:32
Согласование ППТ и ПМТ объекта федерального значения iren_kors Автомобильные и железные дороги, мосты, тоннели и организация движения 3 03.08.2016 20:34
Как создать TEXT, MTEXT с содержимым, равным значению атрибутов объекта rouble AutoCAD 2 12.08.2015 14:24
Получить метку объекта в vba best_vint Программирование 18 13.10.2014 15:31