Анкерные системы Schöck Dorn
dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Расчленение блока и перемещение объектов на передний план (VBA)

Расчленение блока и перемещение объектов на передний план (VBA)

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 22.01.2017, 00:08 #1
Расчленение блока и перемещение объектов на передний план (VBA)
Theodor
 
Петрозаводск
Регистрация: 16.04.2009
Сообщений: 102

Theodor вне форума Вставить имя

Коллеги, доброго здоровичка!
Выручайте, не могу побороть проблемку в VBA.

Средствами метода .explode взрываю блок, но в блоке есть "маскировка". Важно, что бы все примитивы блока после расчленения были выше этой "маскировки" (так сказать на переднем плане чертежа). Кроме того, саму "маскировку" нельзя отправлять на задний план.

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

Массив после расчленения получаю так:
Dim SetExpBlock as variant
SetExpBlock=OBlock.Explode 'OBlock - это статический блок на чертеже

а тут начинаются проблемы:
- как из набора (массива) убрать элемент "маскировка"? Найти их при переборке получается, но как убрать? Не удалив при этом сам объект с чертежа.
If TypeName(SetExpBlock(Index)) = "IAcadRasterImage" Then ...

И как этот массив (набор) подсунуть в метод переноса на передний план (попытка ниже)? У меня от VBA одна ругань на неопределенные переменные. Я просто запутался в их типах.

Перемещение объектов на передний план пытаюсь сделать методом
Dim DrawDic As Object
Dim MObj As Object
Set DrawDic = ThisDrawing.ModelSpace.GetExtensionDictionary
Set MObj = DrawDic.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
MObj.MoveToTop SetObjs ' SetObjs - объект или набор - тут не понятно


В общем: как получить все объекты расчленения блока, и те из них, которые не являются "маскировкой" (растровым изображением), переместить на передний план?

Спасибо за понимание.
Прошу прощения, что не оформил код
Просмотров: 2119
 
Непрочитано 22.01.2017, 13:18
#2
doctorraz

электрик
 
Регистрация: 19.02.2010
Волгоград
Сообщений: 937
Отправить сообщение для doctorraz с помощью Skype™


ну и перемещай обьекты на передний план в цикле, начиная с маскировки
обьекты блока будут поверх нее, а маскировка поверх обьектов чертежа
__________________
Мастерская СПДС
doctorraz на форуме вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 29.07.2017, 00:13
#3
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Прошу прощения с давность темы

Цитата:
Сообщение от doctorraz Посмотреть сообщение
ну и перемещай обьекты на передний план в цикле, начиная с маскировки
обьекты блока будут поверх нее, а маскировка поверх обьектов чертежа
Дело том, что в цикле перемещать каждый объект - процесс долгий. Учитывая то, что функционал VBA позволяет перемещать сразу набор. Вот и хочется получив набор разбитого блока переместить сразу, но при этом убрать из набора маскировку
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 29.07.2017, 11:13
#4
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Создать новый массив с размером -1 от набора.
засунуть в этот массив всё из набора за исключением маскировки
это перебором, но будут быстрее чем каждый на верх.
массив переместить на верх целиком.
это теоретически, но думаю должно работать
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 29.07.2017, 15:44
#5
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Цитата:
Сообщение от maratovich Посмотреть сообщение
это теоретически, но думаю должно работать
Это работает, проверено. Но переборка массива - долгий процесс. Вот как бы от него уйти.
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 29.07.2017, 15:49
#6
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Цитата:
Сообщение от Theodor Посмотреть сообщение
Но переборка массива - долгий процесс. Вот как бы от него уйти.
никак
Цитата:
Сообщение от Theodor Посмотреть сообщение
Кроме того, саму "маскировку" нельзя отправлять на задний план.
в смысле программно или по условию задачи ?

----- добавлено через ~4 мин. -----
Как вариант
получаете габарит блока, взрываете, создаёте набор 1 с фильтром который берёт только маскировку, вырезаете маскировку, создаёте набор 2 со всеми элементами без маскировки, вставляете маскировку, перемещаете набор 2 на верх.
С вас пиво.
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 29.07.2017, 17:09
#7
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Цитата:
Сообщение от maratovich Посмотреть сообщение
вырезаете маскировку,
вот тут таиться проблема! как без перебора получить набор без маскировки, пригодный для .MoveToTop
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 29.07.2017, 17:14
#8
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


ну блин.... на сухую сложно писать...
кидаешь свой набор в коодинаты 100000 на 100000
обрабатываешь как я описал выше
перемещаешь набор в свои координаты.
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 29.07.2017, 21:18
#9
doctorraz

электрик
 
Регистрация: 19.02.2010
Волгоград
Сообщений: 937
Отправить сообщение для doctorraz с помощью Skype™


как вам это удается.. без строчки кода и прииера чертежа.. профи !!!
послежу, почитаю
__________________
Мастерская СПДС
doctorraz на форуме вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 29.07.2017, 21:53
#10
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Делаем эксплоде, получаем массив всего содержимого блока, так ?
Этот массив делаем муве в космос, получилось?
По координатам массива делаем селект сет с фильтром на маскировку, получаем ее и делаем муве в исходное координаты, получилось?
Потом опять селект сет на оставшееся в космосе, и муве в исходные.
По логике маскировка должна получиться снизу.
Пишу смобилы проверить не могу.
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 14:13
#11
Boxa

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


Цитата:
Сообщение от Theodor Посмотреть сообщение
Важно, что бы все примитивы блока после расчленения были выше этой "маскировки" (так сказать на переднем плане чертежа). Кроме того, саму "маскировку" нельзя отправлять на задний план.
Код:
[Выделить все]
Sub dhjs()

    Dim OBlock As AcadObject
    Dim basePnt() As Variant
    
    ThisDrawing.Utility.GetEntity OBlock, basePnt, "Select an object"
    
    Dim SetExpBlock As Variant
    SetExpBlock = OBlock.Explode
    
    Dim count As Integer
    count = 0
    For Each SetObj In SetExpBlock
        If TypeName(SetObj) <> "IAcadWipeout" Then
            count = count + 1
        End If
    Next

    ReDim nObj(count - 1) As Object
    Dim i As Integer
    For Each SetObj In SetExpBlock
        If TypeName(SetObj) <> "IAcadWipeout" Then
            Set nObj(i) = (SetObj)
            i = i + 1
        End If
    Next
    

    Dim DrawDic As Object
    Dim MObj As Object
    Set DrawDic = ThisDrawing.ModelSpace.GetExtensionDictionary
    Set MObj = DrawDic.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
       
    MObj.MoveToTop nObj

End Sub
Boxa на форуме вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 30.07.2017, 14:58
#12
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Коллеги, я понял в чем основной затык, который не дает обойтись без перебора. Нет возможности в .MoveToTop подсунуть набор, там требуется массив объектов.
На данный момент у меня уже есть реализация схожая с решением от Boxa, но она замедлена циклом, и я думал, что должно быть более оптимальное решение. Хотя, кое что попробую еще упростить.
Кстати, Boxa, отсечение маскировок делал сравнивая с "IAcadRasterImage" вместо "IAcadWipeout". Вроде то же работает. Ну и пока обхожусь одним циклом. Два перебора, мне совсем печально будет.
maratovich, к сожалению применение "космоса" меня пока не избавляет от создания массива циклом.
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 15:02
#13
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Theodor приложи пример, а то "много времени на обработку" каждый по разному понимает.
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 15:09
#14
Boxa

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


Theodor, если Вам хочется скорости и гибкости, то это явно не про VBA.
Boxa на форуме вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 15:14
#15
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Файл примера dwg и сколько времени у тебя уходит на обработку.
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 30.07.2017, 15:44
#16
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Цитата:
Сообщение от Boxa Посмотреть сообщение
если Вам хочется скорости и гибкости, то это явно не про VBA
Тут не поспоришь. Но как говориться, на безрыбье и рак рыба. Альтернативные языки для данной задачи изучать нет желания. Вот и ищу оптимизацию на том уровне, которым владею.


Цитата:
Сообщение от maratovich Посмотреть сообщение
приложи пример, а то "много времени на обработку" каждый по разному понимает.
Цитата:
Сообщение от maratovich Посмотреть сообщение
Файл примера dwg и сколько времени у тебя уходит на обработку.
Боюсь что объективности все равно не получить, тут и от машины зависит. Да и помимо переноса объектов программа загружена еще другими параллельными действиями, которые просто усложнят понимание моего кода.
В целом я уже благодаря этой дискуссии понял, что минимум один цикл нужен (из-за разницы в типах данных). Видимо придется смириться.

Кстати, о словарях сортировки. Может кто имеет в них более глубокое познание:
- если я создаю один словарь и начну его использовать для разных сортировок, то это не приведет к откату первых? То есть: создал в словаре сортировку, при помощи нее сгруппировал объекты (одни расположил над другими). Потом взял под другие объекты и при помощи того же словаря сгруппировал (вторые разместит над третьими).. И не получится так, что из-за этого сортировка первых со вторыми вернется на свои места?
Этот вопрос исключительно, если владеете информацией. Целенаправленно проверять не надо.

Спасибо.
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 15:48
#17
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Цитата:
Сообщение от Theodor Посмотреть сообщение
Видимо придется смириться.
А зря...
Нужен блок для тестов
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 30.07.2017, 16:14
#18
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


Цитата:
Сообщение от maratovich Посмотреть сообщение
А зря...
Нужен блок для тестов
Обнадеживаете.... Ладно, будет время, накидаю тестовую версию.
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 30.07.2017, 18:12
#19
Theodor


 
Регистрация: 16.04.2009
Петрозаводск
Сообщений: 102


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

И прилагаю файл, где есть две пачки блоков (по 100 штук). В них отличается число примитивов и при обработке этих пачек наблюдается снижение скорости почти в два раза.

Код:
[Выделить все]
Public Sub temporary()
 Dim SelSet As AcadSelectionSet
 Dim objBlock As AcadBlockReference
 Dim intType(0) As Integer
 Dim varDat(0) As Variant
 Dim arr() As AcadObject
 Dim Cnt As Long
 Dim eDictionary As Object
 Dim SentityObj As Object
 Dim SetObj As Variant
 Dim Ind As Long
 
 intType(0) = 0
 varDat(0) = "INSERT"
 
 For Each SelSet In ThisDrawing.SelectionSets
  If SelSet.Name = "MYSELSET" Then
   SelSet.Delete
   Exit For
  End If
 Next SelSet
 
 Set SelSet = ThisDrawing.SelectionSets.Add("MYSELSET")
 SelSet.SelectOnScreen FilterType:=intType, FilterData:=varDat
 If SelSet.count < 1 Then Exit Sub
 
 Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
On Error Resume Next
 Set SentityObj = eDictionary.GetObject("MYSORTDICT")
On Error GoTo 0
 If SentityObj Is Nothing Then
  Set SentityObj = eDictionary.AddObject("MYSORTDICT", "AcDbSortentsTable")
 End If
 
 For Each objBlock In SelSet
  Cnt = 0
  SetObj = objBlock.Explode
  ReDim arr(UBound(SetObj))
  For Ind = LBound(SetObj) To UBound(SetObj)
   If TypeName(SetObj(Ind)) <> "IAcadRasterImage" And TypeName(SetObj(Ind)) <> "IAcadWipeout" And TypeName(SetObj(Ind)) <> "IAcadWipeout2" Then
    Set arr(Cnt) = SetObj(Ind)
    Cnt = Cnt + 1
   End If
  Next Ind
  If Cnt > 0 Then
   ReDim Preserve arr(Cnt - 1)
   SentityObj.MoveToTop arr
  End If
 Next objBlock
End Sub
Рекомендую включить контуры маскировок
Вложения
Тип файла: dwg
DWG 2007
На передний план.dwg (87.2 Кб, 4 просмотров)
Theodor вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 30.07.2017, 19:11
| 1 #20
maratovich


 
Регистрация: 12.07.2009
г. Самара
Сообщений: 2,100
Отправить сообщение для maratovich с помощью Skype™


Цитата:
Сообщение от Theodor Посмотреть сообщение
Кроме того, саму "маскировку" нельзя отправлять на задний план.
Собственно кто это сказал ?
Вот код переноса назад:
Код:
[Выделить все]
Sub dhjs()
    Dim OBlock As AcadObject
    Dim basePnt() As Variant
    
    ThisDrawing.Utility.GetEntity OBlock, basePnt, "Select an object"
    
    Dim SetExpBlock As Variant
    SetExpBlock = OBlock.Explode
    OBlock.Erase

    Dim arrObj(0) As AcadObject

    For Each SetObj In SetExpBlock
        If TypeName(SetObj) = "IAcadWipeout" Then
            Set arrObj(0) = SetObj
        End If
    Next

    Dim eDictionary As Object
    Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
    On Error Resume Next
    Dim sentityObj As Object
    Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
    On Error GoTo 0
    If sentityObj Is Nothing Then
         Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
    End If
    sentityObj.MoveToBottom arrObj
    Application.Update
End Sub
Сегодня копать некогда, но спрошу:
А не лучше селект сет с фильтром выбрать и взорвать все блоки , а потом так же выбрать только маскировку и переместить назад ?
Или есть каки то особенности что надо каждый блок по очереди ?

----- добавлено через 26 сек. -----
Я ж говорю - на сухую плохо идёт
__________________
Вопрос : Где находится Тургай ? Ответ : Между Парагваем и Уругваем.....
maratovich вне форума вставить имя Обратить внимание модератора на это сообщение  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Расчленение блока и перемещение объектов на передний план (VBA)

Инженерные консультации
Опции темы Поиск в этой теме
Поиск в этой теме:

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

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как сделать макрос на расчленение объектов MagiCAD 2011.11/Ru Alex_GSP Программирование 12 04.11.2015 12:38
Visual LISP: Почему перебор объектов в SelectionSet неактивного документа происходит очень медленно? Shourick LISP 15 13.03.2015 15:23
Функция чтения свойств и их значений динамического блока Supermax Библиотека функций 8 07.09.2014 14:47
Присвоение атрибуту блока значения атрибута другого блока. shartal Программирование 4 14.11.2013 14:02
Проблема с базовой точкой блока и вхождением блока в DXF nogaems Программирование 5 29.08.2013 15:46

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||


Размещение рекламы