[AntonFox]

Есть чертеж в котором много разного текста, порой схожего частями (например TI и TIR).
При выделении текста (только текст! многострочного текста нет и не надо!), например TI, и запуска программы по кнопке, должны выделиться ВСЕ текстовые примитивы содержащие ТОЛЬКО TI. То есть полное совпадение. Затем вручную изменяется текст, выделяется новый и так далее.
Использование ПОИСК И ЗАМЕНА меняет все похожее, то есть и TIR тоже заменит, что не требуется.
Быстрый выбор безусловно выполнит все как надо, но при этом надо тыкнуть в него, затем выбрать ТЕКСТ, СОДЕРЖИМОЕ, ввести нужный текст и нажать ОК. Долго.. особенно если учесть что таких замен много надо сделать.

Пытаюсь написать код на ВБА (немного знаю), но не могу решить следующие проблемы:
- как в программу передать выделенный текстовый примитив?
- как сделать фильтр для добавления нужного текста в выделение?
- как оставить выделение после работы программы?
Все что смог - выделить весь текст в файле. И то думаю что получилось, так как посл закрытия программы выделения нет.

Код:

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

Sub textgr1()

Dim i, j, kol, kol2 As Integer
Dim sele As AcadSelectionSet 

    On Error GoTo 1
    Set sele = ThisDrawing.SelectionSets.Add("test")    
1:  Set sele = ThisDrawing.SelectionSets.Item("test")  
    
    j = 0
    kol2 = 0
    kol = ThisDrawing.ModelSpace.Count
    For i = 0 To kol - 1
     If TypeOf ThisDrawing.ModelSpace.Item(i) Is AcadText Then kol2 = kol2 + 1
    Next
    
    ReDim ssobjs(0 To kol2 - 1) As AcadEntity
    For i = 0 To kol - 1
        If TypeOf ThisDrawing.ModelSpace.Item(i) Is AcadText Then
          Set ssobjs(j) = ThisDrawing.ModelSpace.Item(i)
          j = j + 1
        End If
    Next
    
    sele.AddItems ssobjs

End Sub

На форумах и в подсказках ничего конкретного не нашел. Акад2007

[baksconstructor]

Спасибо не булькает.

Код:

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

Sub Zamena()

Dim FindTEXT
Dim NewTEXT

Dim pickPt
Dim oEnt As AcadEntity
Dim oEntText As AcadText
'-------------------------------------------+
'Указать объект образец
ThisDrawing.Utility.GetEntity oEnt, pickPt, vbCrLf & "Select entity:"
If Not oEnt Is Nothing Then
    If oEnt.ObjectName = "AcDbText" Then
    Set oEntText = oEnt
    FindTEXT = oEntText.TextString
    Else
    Exit Sub
    End If
Else
    Exit Sub
End If
'-------------------------------------------+
'Указать новый текст
NewTEXT = InputBox("Введите новое значение")
'-------------------------------------------+
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
'Адекватная проверка существования набора и его удаление
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "NaborName" Then
ThisDrawing.SelectionSets.Item("NaborName").Delete
Exit For
End If
Next
'-------------------------------------------+
'Создание нового набора
Set objSelSet = ThisDrawing.SelectionSets.Add("NaborName")
'-------------------------------------------+
'Условие набора
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 0
FilterData(0) = "TEXT"
objSelSet.Select acSelectionSetAll, , , FilterType, FilterData
'-------------------------------------------+
'Обработка набора
Dim EntCount As AcadEntity
Dim nn
nn = 0
  For Each EntCount In objSelSet
    If FindTEXT = EntCount.TextString Then
    EntCount.TextString = NewTEXT
    nn = nn + 1
    End If
  Next EntCount
'-------------------------------------------+
ThisDrawing.Regen acActiveViewport
'-------------------------------------------+
MsgBox "Готово. Заменено - " & nn
End Sub

[AntonFox]

А какие еще есть варианты кроме Спасибо? )))
Все замечательно, хотя немного не то что я хотел. Точнее задача решается и итог тот что мне нужен был, но решение немного иное.
Я хотел выделить текст, запустить программу, она выделила нужное и все. Дальше сам.
А у вас получается, что и выбор начального текста, и ввод нового значения, и замена происходят в программе. Пока не понял удобнее это или нет.

Но в принципе возможен мой вариант когда программа только выделяет нужное на основе предвыбора текста? Или по закрытию программы выделение слетит все равно?

И в любом случае спасибо - буду изучать программу построчно что бы понять все до конца.

[baksconstructor]

Сейчас времени нет, но копайте в сторону выбора выбранных элементов:

Код:

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

Public Sub testPickfirst()
Dim ss As AcadSelectionSet

Set ss = ThisDrawing.ActiveSelectionSet
  ReDim ssobjs(0 To ss.Count - 1) As AcadEntity
    Dim I
    For I = 0 To ss.Count - 1
        Set ssobjs(I) = ss.Item(I)
    Next
    Dim newset As AcadSelectionSet
    Set newset = ThisDrawing.SelectionSets.Add("newset")

    newset.AddItems ssobjs

     MsgBox newset.Count

End Sub

А как выделить на чертеже ищите на форуме.

[AntonFox]

Еще раз спасибо!
Если все получится - выложу сюда результат.

[art_rrc]

Сообщение от baksconstructor Сейчас времени нет, но копайте в сторону выбора выбранных элементов: Код: [Выделить все] Public Sub testPickfirst() Dim ss As AcadSelectionSet Set ss = ThisDrawing.ActiveSelectionSet ReDim ssobjs(0 To ss.Count - 1) As AcadEntity Dim I For I = 0 To ss.Count - 1 Set ssobjs(I) = ss.Item(I) Next Dim newset As AcadSelectionSet Set newset = ThisDrawing.SelectionSets.Add("newset") newset.AddItems ssobjs MsgBox newset.Count End Sub А как выделить на чертеже ищите на форуме.

Хоть у кого-то работает этот код (или подобный)? Я как ни пробовал, предварительного выбора от VBA добиться не удалось..(

[baksconstructor]

Сообщение от art_rrc Хоть у кого-то работает этот код (или подобный)? Я как ни пробовал, предварительного выбора от VBA добиться не удалось..(

Del

Код:

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

Public Sub testPickfirst()
Dim oDoc As AcadDocument
Dim ss As AcadSelectionSet

Set oDoc = Application.ActiveDocument
Set ss = oDoc.ActiveSelectionSet

MsgBox ss.Count - 1
End Sub

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

Код:

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

Public Sub test()
Dim selset as AcadSelectionSet
Dim ssName as String
ssName = "dwgRu_prevSS"
On Error Resume Next
ThisDrawing.SelectionSets(ssName).Delete
On Error Goto 0
Set selset =ThisDrawing.SelectionSets.Add(ssName)
selset.Select acSelectionSetPrevious
MsgBox selset.Count
End Sub

Код проверь - при перепечатке я мог допустить ошибки и очепятки

[AntonFox]

Я совместил первых два кода (может и не очень корректно)

Код:

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

Sub zam()

Dim FindTEXT
Dim NewTEXT
Dim EntCount As AcadEntity
Dim pickPt
Dim oEnt As AcadEntity
Dim oEntText As AcadText
'-------------------------------------------+
Dim ss, newset As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
'Адекватная проверка существования набора и его удаление
Set objSelCol = ThisDrawing.SelectionSets
For Each newset In objSelCol
  If newset.Name = "NaborName" Then
    ThisDrawing.SelectionSets.Item("NaborName").Delete
  Exit For
  End If
Next
'-------------------------------------------+
'объект образец
Set ss = ThisDrawing.ActiveSelectionSet
  ReDim ssobjs(0 To ss.Count - 1) As AcadEntity
    Dim I
    For I = 0 To ss.Count - 1
        Set ssobjs(I) = ss.Item(I)
    Next

    Set newset = ThisDrawing.SelectionSets.Add("NaborName")
    
    newset.AddItems ssobjs

    For Each EntCount In newset
      If EntCount.ObjectName = "AcDbText" Then FindTEXT = EntCount.TextString
    Next


'-------------------------------------------+
'Указать новый текст
NewTEXT = InputBox("Введите новое значение")
'-------------------------------------------+
'Создание нового набора
'Set ss = ThisDrawing.SelectionSets.Add("NaborName")
'-------------------------------------------+
'Условие набора
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 0
FilterData(0) = "TEXT"
ss.Select acSelectionSetAll, , , FilterType, FilterData
'-------------------------------------------+
'Обработка набора
Dim nn
nn = 0
  For Each EntCount In ss
    If FindTEXT = EntCount.TextString Then
      EntCount.TextString = NewTEXT
      nn = nn + 1
    End If
  Next EntCount
'-------------------------------------------+
ThisDrawing.Regen acActiveViewport
'-------------------------------------------+



MsgBox "Готово. Заменено - " & nn
End Sub

В итоге выделяю текст, запускаю макрос, спрашивает новое значение и меняет на листе с выдачей сообщения о количестве замен. Так что код рабочий.
Вот только порой наблюдается глюк - то ошибку выдаст, то поменяет текст не удовлетворяющий условиям. Ощущение что "хвосты" остаются в какой-то переменной.


Остался только вопрос с выделением всех примитивов которые заменил, чтоб выделение после завершения программы (макроса) осталось.

[art_rrc]

Сообщение от Кулик Алексей aka kpblc selset.Select acSelectionSetPrevious

А ларчик просто открывался. Вот уж точно, когда знаешь - все просто! (с)
Огромное спасибо Вам, Алексей!

[AntonFox]

А теперь представим, что сначала было выбрано не то что надо, затем запущен макрос и... Начальная выборка уже не та... Или если сначала выбрали не то, потом то, что надо и запустили макрос - предыдущая выборка эта как раз неправильная. Так?

[baksconstructor]

Так...