[zZombie]

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

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

----- добавлено через ~22 мин. -----
SelectAtPoint?

[Boxa]

а не проще перебрать объекты модели, фильтруя тексты и сравнивая координаты... просто select имеет ограничения - объект должен быть виден на экране

[Сергей812]

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

[Автон]

Сообщение от Сергей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")

[zZombie]

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

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

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

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

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

----- добавлено через ~4 мин. -----
Изначально хотел выбирать все полилинии и запускать макрос на VBA для обработки.
Но не соображу как получить объект ТЕКСТ что бы его обработать.
Наверное все таки нужно делать как Boxa подсказал.

[LenidSN]

Код:

[Выделить все]

 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

[Сергей812]

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

Код:

[Выделить все]

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-интерфейса из экселя, но принцип не меняется. Только смотрю, программа небрежно служебные поля лепит в трубных узлах поверх друг друга, соответственно и новый текст тоже накладывается. Т.е. еще придется анализировать - не совпадают ли исходные тексты по точке вставки и тогда добавлять дополнительные смещения для новых текстов.

[zZombie]

Сообщение от Сергей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

Спасибо за подсказки!

[Кулик Алексей aka kpblc]

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

[Сергей812]

Код:

[Выделить все]

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(Индекс)

[zZombie]

Сообщение от Сергей812 получаете постоянное перераспределение памяти при каждой иттерации цикла с нахождением полилинии. И почему просто коллекцию не взять?

да, Вы правы, с коллекциями будет правильней. Спасибо.