[МишаИнженер]

Подскажите пожалуйста код на VBA для добавления объектов в текущий набор выделенных объектов на чертеже.

[МишаИнженер]

Сообщение от engngr _g

Ни одну команду АвтоКАД не понимает:
Команда: "_.Select" Неизвестная команда "SELECT"". Для вызова справки нажмите F1.
Команда: & Неизвестная команда "&". Для вызова справки нажмите F1.
Команда: vbCr Неизвестная команда "VBCR". Для вызова справки нажмите F1.
Команда: & Неизвестная команда "&". Для вызова справки нажмите F1.
Команда: "_g" Неизвестная команда ""_G"". Для вызова справки нажмите F1.
Команда: & Неизвестная команда "&". Для вызова справки нажмите F1.
Команда: vbCr Неизвестная команда "VBCR". Для вызова справки нажмите F1.
Команда: & Неизвестная команда "&". Для вызова справки нажмите F1.
Команда: "TEMPGROUP"
Неизвестная команда ""TEMPGROUP"". Для вызова справки нажмите F1.
Что-то поменялось в новом АвтоКАДе. Наверное есть другая команда, заменяющая SELECT, но как называется эта команда?

[Boxa]

МишаИнженер, Вообще не смешно. Складывается впечатление, что Вы троль. Желание Вам помогать или подталкивать в правильном направлении стремительно таит.

[Сергей812]

Сообщение от Boxa Складывается впечатление, что Вы троль.

такие нынче "инженеры") Даже готовое решение в пределах того же форума не способны найти неделями...

[МишаИнженер]

Спасибо Сергей812!

Сообщение от Сергей812 в пределах того же форума не способны найти неделями...

Функция заработала! Однако есть маленький недочет:
При вызове функции SelectOnScreen снимается выделение с ранее выделенных объектов и на экране не видно какие объекты были выделены ранее и какие сейчас выделять не надо
Как одновременно подсветить объекты и попросить пользователя выбрать новые?
Может для этого есть специальные функции Лисп?
Скачайте пожалуйста файл Excel и проверьте как работает функция и помогите исправить недочет!

[doctorraz]

Сообщение от МишаИнженер Как одновременно подсветить объекты и попросить пользователя выбрать новые?

тебе выше Сергей812 дал ссылку как подсветить объекты набора..
Что мешает заказать юзеру новый выбор в тотжэж селсет и еще раз подсветить этот набор с новыми объектами?

----- добавлено через ~5 мин. -----
Зачем мучить юзера множественными выборами..
Не проще сделать селсет с кодом 4 и выбрать все что нужно за один раз?

[Сергей812]

Сообщение от doctorraz Что мешает заказать юзеру новый выбор в тотжэж селсет и еще раз подсветить этот набор с новыми объектами?

возможно, что ТС не знает - как дубликаты повторного выбора одних и тех же элементов исключать

Сообщение от МишаИнженер и на экране не видно какие объекты были выделены ранее и какие сейчас выделять не надо

хотя это делается элементарно с использованием Collection и хэндла как ключ.

[doctorraz]

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

они и так повторно в селсет не попадут))

Ломаю голову зачем выбирать несколько раз, если можно за один))

[Сергей812]

Сообщение от doctorraz Ломаю голову зачем выбирать несколько раз, если можно за один))

фиг его знает - как он писал

Сообщение от МишаИнженер Часто приходится выделять множество объектов очень труднодоступных и в большом количестве. Поэтому нужен инструмент позволяющий выделять объекты с помощью фильтров по слою, по цвету и весу линий.

вполне возможно, что некий инструмент для коллекционирования вместе нескольких разных выборок пытается сваять

[doctorraz]

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

Похоже на то, только можно взять одним разом, по любым условиям, хоть со всего документа, хоть через лист...
Секретчики млин.. все боятся идею супер проги запалить, шоб идею не украли)))

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

Offtop: А ТС не реагирует...

[Сергей812]

Сообщение от doctorraz Похоже на то, только можно взять одним разом, по любым условиям, хоть со всего документа, хоть через лист...

это если известны все условия выборки изначально. А может последовательно выбирается - что-то выбрал, потом посмотрел - какие то элементы не попали, дополнительный выбор с добавлением к предыдущему или наоборот, исключением из результирующего набора.. И т.д. в интерактивном режиме. Но шифруется ТС)

[doctorraz]

Сообщение от Сергей812 потом посмотрел - какие то элементы не попали, дополнительный выбор с добавлением к предыдущему

Селсетом... интерактивно добавить.. после как посмотрел)))
Сильно шифруется. Даже представить такую задачу не могу, где требуется такой интерактив.

[Сергей812]

Сообщение от doctorraz Даже представить такую задачу не могу, где требуется такой интерактив.

ну обычно наоборот - к элементам привязываются какие то признаки (как привязываются - это уже другой вопрос), и далее по этим признакам производится какая то манипуляция с элементами, в том числе и выделение при необходимости.

Придет ТС - может, приоткроет завесу тайны, зачем это все нужно)

[МишаИнженер]

При армировании ЖБ конструкций сетками на проекциях сечений надо часто рисовать проекции сеток. Эти проекции я делаю в виде блоков. Круглешочки я рисую блоками в названии которых видно какой это диаметр (это удобная фишечка). И вот чтобы эти точки не выделять по одной (чтобы их все добавить в блок) мне нужен инструмент "добавить объекты к выделенным объектам" и ещё у меня есть код (и инструмент такой есть) "Выделить блоки из выделенных объектов". Я просто выделяю область чертежа, потом выделяю блок (например точку арматуры или блок обозначения хомута) и мне тут-же подсвечиваются эти боки на экране и выдается сообщение: "было выделено N объектов среди них найдено M блоков с названием ..." И я сразу записываю в спецификацию число хомутов стягивающих две сетки по смежным плоскостям блока. А теперь я могу выделять с помощью таких фильтров сразу множество одинаковых блоков, например точки стержней на проекциях сеток, и добавлять потом все выделенные объекты в блок: "СеткаС5_Спереди", "СеткаС5_Сбоку", "СеткаС5_План" и т.д. А далее можно крутить эти блоки проекции и прилаживать их к другим проекциям и проверять правильность вычерчивания сетки и настраивать шаг между стержнями чтобы стержни разных сеток не пересекались. Вот для чего мне нужна эта функция!
Если вы мне подскажите как обозначить ранее выделенные объекты в процессе выделения новых объектов я вам покажу все эти инструменты на одном листе и вы сможете оценить их работу. А сейчас времени пока нет надо чертежи армировать. Подумайте как это сделать. Мне кажется что придется красным цветом выделять ранее выделенные объекты, а после добавления новых объектов к ранее выделенным цвет надо будет заменить на старые цвета которые были до выделения. Это можно сделать и с весом линий. А какие у вас будут предложения? Может для этого есть специальная функция ЛИСП?

Вопрос модератору: как включить интерактивную проверку грамматики и орфографии в сообщениях?

[Сергей812]

типа тут на форуме каждый второй КЖ/КМ - чтобы воспринять этот поток сознания без каких либо иллюстраций) Только если будете править цвет примитивов - имхо, добавляйте им в расширенные данные исходный цвет, чтобы в случае сбоя приложения можно было восстановить исходное состояние одной командой.

[Савелий Пак]

Даже через 17 лет задача не решена. Я даже в форум записался

[Сергей812]

Сообщение от Савелий Пак Даже через 17 лет задача не решена. Я даже в форум записался

Какая задача? и через каких 17 лет - теме 4 года всего...

[trir]

Просто VB умер

[МишаИнженер]

Вот код рабочей программы:

Код:

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

Public Sub ДобавитьСтержниКВыделенномуНаборуСтержней()
'Функция добавляет стержни заданного типа к выделенному набору стержней
Dim objПриложениеAutoCAD As AcadApplication, objAcadDoc As AcadDocument
Dim objТекВыдОбъекты As AcadSelectionSet, objSelection As AcadSelectionSet, objSelПодсветка As AcadSelectionSet
Dim bПрОткл As Boolean
Dim mОбъекты() As AcadEntity
Dim I As Long, J As Long, K As Long, L As Long
Dim grpTemp As AcadGroup
'Переменные для параметров линии
Dim sСлой As String, vЦвет As Variant, vТипЛиний As Variant, vВесЛиний As Variant, dМКТЛиний As Double, sНазвОбъекта As String
Dim СпДопВыдОбъектов As Collection, objОбразец As AcadEntity, objТекЛиния As AcadEntity
On Error GoTo ОбработкаОшибок
'Получить объекты Excell и AutoCAD
   Call ПолучитьОбъектыExcellИAutoCAD(objПриложениеAutoCAD, objAcadDoc)

'Получим список выделенных объектов на чертеже
   Set objТекВыдОбъекты = objAcadDoc.ActiveSelectionSet
   Set objТекВыдОбъекты = objAcadDoc.PickfirstSelectionSet
   objТекВыдОбъекты.Highlight True
   I = objТекВыдОбъекты.count
   
'Получим список объектов из которых надо отфильтровать новые выделенные объекты
   Call ПоказатьAutoCAD(objAcadDoc)
   If ПризнакНаличияЭлементаВКоллекции("ВыделенныеОбъекты", objAcadDoc.SelectionSets, 2) Then
      objAcadDoc.SelectionSets("ВыделенныеОбъекты").Delete
   End If
   Set objSelection = objAcadDoc.SelectionSets.Add("ВыделенныеОбъекты")
      
On Error Resume Next
   Call ПоказатьAutoCAD(objAcadDoc)
   objSelection.SelectOnScreen

'Получим объект образец по свойствам которого будем отфильтровывать новые выделеннные объекты
   Call ПолучитьОбъектЧертежа(objAcadDoc, objОбразец, "Выдели объект которые надо добавить в набор выделения", "объект", bПрОткл)
   If bПрОткл = True Then Exit Sub

'Отфильтруем выделенные объекты по свойствам объекта образца
'Запомним параметры объекта образца
   sСлой = objОбразец.Layer
   sНазвОбъекта = objОбразец.ObjectName
   vЦвет = objОбразец.Color
   vТипЛиний = objОбразец.LineType
   vВесЛиний = objОбразец.LineWeight
   dМКТЛиний = objОбразец.LinetypeScale
   Set СпДопВыдОбъектов = New Collection
   K = objSelection.count
   For L = 0 To K - 1
      Set objТекЛиния = objSelection(L)
      Do
         If objТекЛиния.ObjectName <> sНазвОбъекта Then Exit Do
         If objТекЛиния.Layer <> sСлой Then Exit Do
         If objТекЛиния.Color <> vЦвет Then Exit Do
         If objТекЛиния.LineType <> vТипЛиний Then Exit Do
         If objТекЛиния.LineWeight <> vВесЛиний Then Exit Do
         If objТекЛиния.LinetypeScale <> dМКТЛиний Then Exit Do
         'Объект прошел все проверки. Добавим его в дополнительный набор выделения
         СпДопВыдОбъектов.Add objТекЛиния
      Loop Until True
   Next L

On Error GoTo ОбработкаОшибок
   J = СпДопВыдОбъектов.count
   ReDim mОбъекты(0 To I + J - 1) As AcadEntity
   For L = 0 To I - 1
      Set mОбъекты(L) = objТекВыдОбъекты(L)
'      objТекВыдОбъекты(L).Highlight True
   Next L
   For L = 1 To J
      Set mОбъекты(I + L - 1) = СпДопВыдОбъектов(L)
'      objSelection(L).Highlight True
   Next L
   K = I + J
   
'Создадим группу выделения "Подсветка"
   If ПризнакНаличияЭлементаВКоллекции("Подсветка", objAcadDoc.SelectionSets, 2) Then
      objAcadDoc.SelectionSets("Подсветка").Delete
   End If
   Set objSelПодсветка = objAcadDoc.SelectionSets.Add("Подсветка")
   objSelПодсветка.AddItems mОбъекты
'Вызовем команду выделения группы "Подсветка"
   objAcadDoc.SendCommand "(progn(defun ss-gripset (/ SS SR SSN I)(vl-load-com)(setq SS(vla-get-selectionsets(vla-get-activedocument (vlax-get-acad-object))) SSN(vla-item SS ""Подсветка"") SR(ssadd))(vlax-for I SSN (ssadd(vlax-vla-object->ename I)SR))(sssetfirst nil SR)(princ))(ss-gripset))\n "
      
'Выведем сообщение о выполненной работе
   objAcadDoc.Utility.Prompt "К текущему набору из " & I & " объектов было добавлено " & J & " выделенных объектов" & vbCrLf & _
   "Всего в текущем наборе объектов " & K & " объектов" & vbCrLf
   
   Exit Sub
ОбработкаОшибок:
   glОтвет = MsgBox("При добавлении выделенных объектов произошла ошибка:" & vbLf & _
         "номер = " & Err.Number & vbLf & _
         "с описанием: " & Err.Description & vbLf & vbLf & _
         "Продолжать выполнение программы?", vbYesNo, gsНазваниеПрограммы)
   If glОтвет = vbNo Then Exit Sub
   Resume Next
End Sub


Public Function ПолучитьОбъектЧертежа(objAcadDoc As AcadDocument, objОбЧ As AcadEntity, sСообщение As String, _
sНазвОбъекта As String, Optional bПрОткл As Boolean = False) As Boolean
'Функция получает объекто чертежа
Dim vIP As Variant
On Error Resume Next
ПолучитьОбъект:
   Call objAcadDoc.Utility.GetEntity(objОбЧ, vIP, sСообщение)
   If Err.Number <> 0 Then
      glОтвет = MsgBox("Продолжать получать " & sНазвОбъекта & " с чертежа?", vbYesNoCancel, gsНазваниеПрограммы)
      Err.Clear
      If glОтвет = vbYes Then
         GoTo ПолучитьОбъект
      ElseIf glОтвет = vbCancel Then
         End
      Else
         ПолучитьОбъектЧертежа = False
         bПрОткл = True
         Exit Function
      End If
   End If
   ПолучитьОбъектЧертежа = True
End Function

[Савелий Пак]

Сообщение от МишаИнженер 'Call the command to select the "Highlight" group objAcadDoc.SendCommand "(progn(defun ss-gripset (/ SS SR SSN I)(vl-load-com)(setq SS(vla-get-selectionsets(vla-get-activedocument (vlax-get-acad-object))) SSN(vla-item SS ""Highlight"") SR(ssadd))(vlax-for I SSN (ssadd(vlax-vla-object->ename I)SR))(sssetfirst nil SR)(princ))(ss-gripset))\n "

Замечательно! Заработало все

'Вызовем команду выделения группы "Подсветка"
objAcadDoc.SendCommand "(progn(defun ss-gripset (/ SS SR SSN I)(vl-load-com)(setq SS(vla-get-selectionsets(vla-get-activedocument (vlax-get-acad-object))) SSN(vla-item SS ""Подсветка"") SR(ssadd))(vlax-for I SSN (ssadd(vlax-vla-object->ename I)SR))(sssetfirst nil SR)(princ))(ss-gripset))\n "

Почему-то короткое сообщение не ушло и цитаты не выделяются (Модератору).

Это - гениально. Программа пошла. Не знаю Lisp (конечно нельзя гордиться этим, но ...).
В знак благодарности могу поделиться набором функций по вычислению триангуляции

----- добавлено через ~3 мин. -----
Вот код построеня тела с помощью команды _LOFT

Код:

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

    Sub sBuildLoft()
        Dim Acad As Object = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As Object = Acad.ActiveDocument

        Dim ssetObj As AcadSelectionSet
        Dim rnd = New Random
        Dim dd = Math.Round(rnd.NextDouble * 1000, 0)
        Dim namSS = "Test0" & dd
        ssetObj = ThisDrawing.SelectionSets.Add(namSS)

        Dim obPL1, obPL2 'As AutoCAD.Acad3DPolyline
        Dim p1(8), p2() As Double
        p1 = {6, 3, 10, 10, 1, 6, 8, 5, 7}
        p2 = {6, 3, 0, 10, 1, 0, 8, 5, 0}
        obPL1 = ThisDrawing.ModelSpace.Add3Dpoly(p1)
        obPL1.Closed = True
        obPL2 = ThisDrawing.ModelSpace.Add3Dpoly(p2)
        obPL2.Closed = True

        Dim mObjects(0 To 1) As AcadEntity
        mObjects(0) = ThisDrawing.ModelSpace.Item(0)
        mObjects(1) = ThisDrawing.ModelSpace.Item(1)


        ssetObj.AddItems(mObjects)

        'Create the "Highlight" selection group 
        'If ElementPresenceInCollectionIndicator("Highlight", ThisDrawing.SelectionSets, 2) Then
        '    ThisDrawing.SelectionSets("Highlight").Delete
        'End If

        Dim objSelHighlight As AcadSelectionSet = ThisDrawing.SelectionSets.Add("Highlight3")
        objSelHighlight.AddItems(mObjects)

        'Call the command to select the "Highlight" group 
        ThisDrawing.SendCommand("(progn(defun ss-gripset (/ SS SR SSN I)(vl-load-com)(setq SS(vla-get-selectionsets(vla-get-activedocument (vlax-get-acad-object))) SSN(vla-item SS ""Highlight3"") SR(ssadd))(vlax-for I SSN (ssadd(vlax-vla-object->ename I)SR))(sssetfirst nil SR)(princ))(ss-gripset))\n ")

        ThisDrawing.SendCommand("_Loft  ")

        objSelHighlight.Delete()

    End Sub