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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Send to back все заливки во всех блоках

Send to back все заливки во всех блоках

Ответ
Поиск в этой теме
Непрочитано 23.09.2009, 10:53 #1
Send to back все заливки во всех блоках
Кочетков Андрей
 
Regular Java Developer
 
Регистрация: 03.02.2006
Сообщений: 4,714

Прошу помочь с написанием программы, которая, перебирая все блоки в чертеже, перемещает на задний план имеющиеся в блоке заливки, не разбивая при этом сам блок.
Если в блоке несколько заливок, то порядок их взаимного следования не имеет значения, за исключением случая присутствия заливки SOLID.
В этом случае заливка SOLID помещается на задний план в последнюю очередь (т.е. ниже всех объектов блока, в том числе других заливок)
__________________
Приглашаю в мой Телеграм-канал: https://tele.gg/middle_java
Просмотров: 4798
 
Непрочитано 23.09.2009, 11:00
#2
Кулик Алексей aka kpblc
Moderator

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


Какая версия AutoCAD? И образец бы глянуть...
А так - можно попробовать vla-movetobottom к заливкам применять.
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 23.09.2009, 11:01
#3
AlexV

Инженер
 
Регистрация: 02.10.2008
С-Пб
Сообщений: 3,656


VBA...
Код:
[Выделить все]
Option Explicit

Sub main()
Dim objBlk As Object
Dim objAllBlks As AcadBlocks
Dim shtrih As Object
    Set objAllBlks = ThisDrawing.Blocks
    For Each objBlk In objAllBlks
       For Each shtrih In objBlk
         If shtrih.ObjectName = "AcDbHatch" Then
            Call Hatch_To_back(shtrih, objBlk)
         End If
       Next shtrih
    Next objBlk
ThisDrawing.Regen acActiveViewport
End Sub

Private Sub Hatch_To_back(Obj, obj2)
'Перенос штриховки на задний план
Dim eDictionary As Object
Set eDictionary = obj2.GetExtensionDictionary
On Error Resume Next
Dim sentityObj As Object
On Error GoTo 0
  Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
    Dim ObjIds As Long
    ObjIds = Obj.ObjectID
    Dim varObject As AcadObject
    Set varObject = ThisDrawing.ObjectIdToObject(ObjIds)
    Dim arr(0) As AcadObject
    Set arr(0) = varObject
    sentityObj.MoveToBottom arr
    AcadApplication.Update
End Sub
Правда, не учитывает возможность наличия перекрывающихся штриховок... Просто тупо все "Hatch" - "to back"
__________________
...Не пытайся гнуть ты ложку,
Не вяжи её узлом.
Ложка - ложка понарошку,
А по правде, - это лом!
AlexV вне форума  
 
Автор темы   Непрочитано 23.09.2009, 11:24
#4
Кочетков Андрей

Regular Java Developer
 
Регистрация: 03.02.2006
Сообщений: 4,714


Прикладываю образец.
Файл в формате 2007ю
В файле блок.
Посмотрел его, появились изменения в алгоритме программы:
  • на задний план отправляются заливки
  • на самый задний план отправляется wipeout

AlexV, не работает прога.
И даже ничего в комстроке не пишет.
Вложения
Тип файла: dwg
DWG 2007
hatch_to_back.dwg (391.0 Кб, 1652 просмотров)
__________________
Приглашаю в мой Телеграм-канал: https://tele.gg/middle_java
Кочетков Андрей вне форума  
 
Непрочитано 23.09.2009, 12:26
#5
AlexV

Инженер
 
Регистрация: 02.10.2008
С-Пб
Сообщений: 3,656


Цитата:
Сообщение от Кочетков Андрей Посмотреть сообщение
...AlexV, не работает прога.
И даже ничего в комстроке не пишет.
Отчего же не работает, просто она работает молча.. Что б wipeout была еще более "back", измени main:
Код:
[Выделить все]
Sub main()
Dim objBlk As Object
Dim objAllBlks As AcadBlocks
Dim shtrih As Object
    Set objAllBlks = ThisDrawing.Blocks
    For Each objBlk In objAllBlks
       For Each shtrih In objBlk
         If shtrih.ObjectName = "AcDbHatch" Then
            Call Hatch_To_back(shtrih, objBlk)
         End If
       Next shtrih
       For Each shtrih In objBlk
         If shtrih.ObjectName = "AcDbWipeout" Then
            Call Hatch_To_back(shtrih, objBlk)
         End If
       Next shtrih
    Next objBlk
ThisDrawing.Regen acActiveViewport
End Sub
Код, может, корявый, но у меня работает...
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.jpg
Просмотров: 132
Размер:	63.0 Кб
ID:	26365  
__________________
...Не пытайся гнуть ты ложку,
Не вяжи её узлом.
Ложка - ложка понарошку,
А по правде, - это лом!
AlexV вне форума  
 
Непрочитано 23.09.2009, 13:56
1 | #6
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,857
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Вот реализация на lisp'е
*** Добавлено
Что и куда посылать сделано ввиде опций функции hatch-to-back
(hatch-to-back 1 "MovetoBottom") ;_ Послать штриховки на самый низ
(hatch-to-back 2 "MovetoBottom") ;_ Послать wipeout на самый низ
(hatch-to-back 3 "MovetoBottom") ;_ Послать штриховки и wipeout на самый низ
Если заменить MovetoBottom на MoveToTop, то соответственно на верх

Код:
[Выделить все]
(defun C:H2B ()
;;hatch to back
;;Send to back все заливки во всех блоках
;;;http://forum.dwg.ru/showthread.php?t=40394
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
   (hatch-to-back 
    3   ;_ what 1 - send to back hatch  2 - send to back wipeout 3 - all
   "MovetoBottom" ;_"MovetoBottom" or "MoveToTop"
   ) 
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (command "_.regenall")
  )
(defun hatch-to-back
                     (what         How          /
                      hatch-list   wipeout-list get-or-create-dict
                      sorttbl      ms           doc
                      xdic
                     )
  ;; what 1 - send to back hatch
  ;;      2 - send to back wipeout
  ;;     3 - send to back hatch and wipeout
  ;; how - "MovetoBottom" or "MoveToTop"
  ;; use
  ;;  (hatch-to-back 1)
  ;;  (hatch-to-back 2)
  ;;  (hatch-to-back (+ 1 2))
  ;;hatch to back
;;;http://forum.dwg.ru/showthread.php?t=40394
  (vlax-for Blk (vla-get-blocks
                  (vla-get-activedocument (vlax-get-acad-object))
                ) ;_ end of vla-get-blocks
    (if (= (vla-get-isxref Blk) :vlax-false)
      (progn
        (setq xdic (vla-getextensiondictionary Blk))
        (if
          (vl-catch-all-error-p
            (setq sorttbl (vl-catch-all-apply
                            'vla-getobject
                            (list xdic "ACAD_SORTENTS")
                          ) ;_ end of vl-catch-all-apply
            ) ;_ end of setq
          ) ;_ end of vl-catch-all-error-p
           (setq sorttbl (vla-addobject
                           xdic
                           "ACAD_SORTENTS"
                           "AcDbSortentsTable"
                         ) ;_ end of vla-addobject
           ) ;_ end of setq
        ) ;_ end of if
        (setq hatch-list   nil
              wipeout-list nil
        ) ;_ end of setq
        (grtext -1
                (strcat "Inspecting objects: "
                        (vla-get-name Blk)
                ) ;_ end of strcat
        ) ;_ end of grtext
        (vlax-for Obj Blk
          (cond ((eq (vla-get-objectname Obj) "AcDbWipeout")
                 (setq wipeout-list (cons Obj wipeout-list))
                )
                ((eq (vla-get-objectname Obj) "AcDbHatch")
                 (setq hatch-list (cons Obj hatch-list))
                )
                (t nil)
          ) ;_ end of cond
        ) ;_ end of vlax-for
        (if (and hatch-list (= (logand what 1) 1))
          (vl-catch-all-apply
            'vlax-invoke-method
            (list sorttbl
                  how
                  (vlax-safearray-fill
                    (vlax-make-safearray
                      vlax-vbobject
                      (cons 0 (1- (length hatch-list)))
                    ) ;_ end of vlax-make-safearray
                    hatch-list
                  ) ;_ end of vlax-safearray-fill
            ) ;_ end of list
          ) ;_ end of VL-CATCH-ALL-APPLY
        ) ;_ end of if
        (if (and wipeout-list (= (logand what 2) 2))
          (vl-catch-all-apply
            'vlax-invoke-method
            (list sorttbl
                  how
                  (vlax-safearray-fill
                    (vlax-make-safearray
                      vlax-vbobject
                      (cons 0 (1- (length wipeout-list)))
                    ) ;_ end of vlax-make-safearray
                    wipeout-list
                  ) ;_ end of vlax-safearray-fill
            ) ;_ end of list
          ) ;_ end of VL-CATCH-ALL-APPLY
        ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
)
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 29.01.2010 в 14:32. Причина: Новая версия
VVA вне форума  
 
Автор темы   Непрочитано 23.09.2009, 14:00
#7
Кочетков Андрей

Regular Java Developer
 
Регистрация: 03.02.2006
Сообщений: 4,714


Ну Люди, спасибо ))
Быстро и качественно ))))
__________________
Приглашаю в мой Телеграм-канал: https://tele.gg/middle_java
Кочетков Андрей вне форума  
 
Непрочитано 23.09.2009, 14:22
#8
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,857
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Немного изменил код в #6. Что и куда посылать сделано ввиде опций функции hatch-to-back, т.к. в своей работе мне нужно, чтобы wipeout был там где я его поставил.
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 08.06.2011, 10:35
#9
Eddicordo

КИП и А
 
Регистрация: 28.04.2010
Киев
Сообщений: 101
<phrase 1=


VVA, Открыл образец с поста №4
Запускаю прогу твою
Команда: (hatch-to-back 3 "MovetoBottom")
nil

че запускать то?
Команда: H2B
_.regenall Выполняется регенерация модели.
Команда: nil

Акад 2010 рус
Может чего я не понял???
Eddicordo вне форума  
 
Непрочитано 08.06.2011, 11:23
#10
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,693
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от Eddicordo Посмотреть сообщение
Команда: H2B
_.regenall Выполняется регенерация модели.
Команда: nil
Все нормально. Судя по коду, так и должно быть. Все WIPEOUT и HATCH при этом в блоках должны переместиться на задний план.
Do$ вне форума  
 
Непрочитано 19.05.2014, 12:34
#11
Nike

Шаражпроектхалтурмонтаж
 
Регистрация: 29.10.2004
Талды-Париж
Сообщений: 5,913


Цитата:
Сообщение от VVA Посмотреть сообщение
(hatch-to-back 1 "MovetoBottom") ;_ Послать штриховки на самый низ
(hatch-to-back 2 "MovetoBottom") ;_ Послать wipeout на самый низ
(hatch-to-back 3 "MovetoBottom") ;_ Послать штриховки и wipeout на самый низ
Выводится сообщение

Команда: (hatch-to-back 2 "MovetoBottom")
; ошибка: Ошибка Automation. Элемента AcRxClassName нет в системном реестре

Не подскажете, в чем дело и как это вылечить? Спасибо!
Nike на форуме  
 
Непрочитано 19.05.2014, 15:04
#12
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,857
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Nike, Могу только посоветовать это почитать

----- добавлено через ~4 мин. -----
И вот еще нашел. Dictionary error
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 19.09.2014, 15:41
#13
kosmi


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


Великолепная штука, VVA, давно хотелось такую сделать, мозгов не хватает. Немного переделал под себя. Идея в том, чтобы управлять по желанию
очерёдностью перемещения примитивов вперёд-назад. Ну т.е. хочешь сначала штриховки, затем маски или наоборот. Добавил ещё управление растрами.
Мне было нужно. Код рабочий, но изяществом не блещет, поэтому прошу подделать по-мастерски (если есть желание).

Код:
[Выделить все]
;;==========================================
;;
;; На задний-передний план МАСКИ, Растры, Штриховки
;; http://forum.dwg.ru/showthread.php?t=40394
;;
;; Что и куда посылать сделано ввиде аргументов функции hatch-to-back
;; (hatch-to-back 1 "MovetoBottom") ;; маски на самый низ
;; (hatch-to-back 2 "MovetoBottom") ;; штриховки на самый низ
;; (hatch-to-back 4 "MovetoBottom") ;; растры на самый низ
;;
;; (hatch-to-back 3 "MovetoBottom") ;; маски и штриховки на самый низ
;; (hatch-to-back 5 "MovetoBottom") ;; маски и растры на самый низ
;; (hatch-to-back 6 "MovetoBottom") ;; штриховки и растры на самый низ
;;
;; (hatch-to-back 7 "MovetoBottom") или (hatch-to-back (+ 1 2 4) "MovetoBottom")
;;  маски, затем штриховки, затем растры на самый низ
;; 
;; при задании аргумента what в виде списка будет учтена очерёдность выполнения 
;; операций согласно порядкового номера бита в списке, т.е. ф-я, заданная в виде:
;; (hatch-to-back '(+ 2 4 1) "MovetoBottom") 
;; переместит вниз сначало штриховки, затем растры, затем маски
;;
;; Разное расположение битов даёт возможность комбинировать перестроения
;;
;; Если заменить MovetoBottom на MoveToTop, то соответственно перемещение на верх
;; 
;;==========================================


;;==========================================
;; вариант: 
;; по-порядку маски/штриховки/растры вниз
;;==========================================
(defun C:RB (/ str)
  (vl-cmdf "_.UNDO" "_Be") 

  (hatch-to-back '(+ 1 2 4) "MovetoBottom")

  (vl-cmdf "_.UNDO" "_End")
  (princ)
)
;;==========================================

(defun hatch-to-back
                     (what       How          /
                      n-list     bit-list     wipeout-list  raster-list  hatch-list  get-or-create-dict
                      sorttbl    ms           doc
                      xdic       *Move_Obj*
                      
                     )

  ;;-------------
  (setq bit-list '(1 2 3 4 5 6 7))

  ;; определим, в каком виде задан аргумент what
  (cond 
    ((member what bit-list)(setq n-list (list what)))
    ((member (vl-catch-all-apply 'eval (list what)) bit-list)          
      (setq 
        n-list (cdr what) ;; список очерёдности
        what (eval what)
      )               
    )
    (T (setq what nil)) ;; если аргумент задан неправильно
  )
  ;;------------- 
  

(if what 
 (progn
  (vlax-for Blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))               
    (if (= (vla-get-isxref Blk) :vlax-false)
      (progn
        (setq xdic (vla-getextensiondictionary Blk))
        (if
          (vl-catch-all-error-p
            (setq sorttbl (vl-catch-all-apply
                            'vla-getobject
                            (list xdic "ACAD_SORTENTS")
                          ) ;_ end of vl-catch-all-apply
            ) ;_ end of setq
          ) ;_ end of vl-catch-all-error-p

           (setq sorttbl (vla-addobject
                           xdic
                           "ACAD_SORTENTS"
                           "AcDbSortentsTable"
                         ) ;_ end of vla-addobject
           ) ;_ end of setq
        ) ;_ end of if


        ;;(setq 
        ;;  wipeout-list nil         
        ;;  hatch-list   nil
        ;;  raster-list  nil
        ;;) 

        (grtext -1
          (strcat "Inspecting objects: "
            (vla-get-name Blk)
          ) 
        ) 

        (vlax-for Obj Blk
          (cond ((eq (vla-get-objectname Obj) "AcDbWipeout") 
                 (setq wipeout-list (cons Obj wipeout-list)) ;; список масок
                )                         
                ((eq (vla-get-objectname Obj) "AcDbHatch")               
                 (setq hatch-list (cons Obj hatch-list))     ;; список штриховок
                )
                ((eq (vla-get-objectname Obj) "AcDbRasterImage")
                 (setq raster-list (cons Obj raster-list))   ;; список растров
                )
                (T nil)
          ) ;_ end of cond
        ) ;_ end of vlax-for


        ;;-------------
        ;; Ф-я применения метода перемещения для списка объектов
        ;;-------------
        (defun *Move_Obj* (Obj-List Bit)      
          (if (and Obj-List (= (logand what Bit) Bit))
            (vl-catch-all-apply
              'vlax-invoke-method
              (list 
                sorttbl
                how
                (vlax-safearray-fill
                  (vlax-make-safearray
                    vlax-vbobject
                    (cons 0 (1- (length Obj-List)))
                  ) ;_ end of vlax-make-safearray
                  Obj-List
                ) ;_ end of vlax-safearray-fill
              ) ;_ end of list
            ) ;_ end of VL-CATCH-ALL-APPLY
          ) ;_ end of if
        ) ;;...defun *Move_Obj*
        ;;-------------

        ;; если аргумент what задан в виде подходящего списка -
        ;; выполнить операции по определённой очерёдности, иначе
        ;; в обычном порядке     
        (foreach i n-list 
          (cond
            ((= i 1)(*Move_Obj* wipeout-list 1))
            ((= i 2)(*Move_Obj* hatch-list  2))
            ((= i 4)(*Move_Obj* raster-list 4))
            (T (*Move_Obj* wipeout-list 1)(*Move_Obj* hatch-list 2)(*Move_Obj* raster-list 4))            
          )
        ) ;;...foreach               
  
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for

  (vla-regen (vla-get-activedocument (vlax-get-acad-object)) T)

  (princ (strcat 
    "\n'\n'\n'\nПеремещение "
    (if (eq how "MovetoBottom") "ВНИЗ" "ВВЕРХ")
    " выполнено!"
  ))

 ) ;;...progn
  
 (alert "Неправильное задание аргумента \"WHAT\" !")
) ;;...if what

) ;;...defun hatch-to-back
kosmi вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Send to back все заливки во всех блоках

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Стройки встали что делать проектировщикам dextron3 Организация проектирования и оформление документации 1033 07.12.2008 12:09
Мировой кризис Moris Разное 2271 07.12.2008 12:07
Юмор 2007 Огурец Разное 1172 29.12.2007 11:16
Флуд Perezz!! Разное 29 07.09.2007 22:04
ЮМОР 2006 =) Perezz!! Разное 1122 04.01.2007 00:46