[Кочетков Андрей]

Прошу помочь с написанием программы, которая, перебирая все блоки в чертеже, перемещает на задний план имеющиеся в блоке заливки, не разбивая при этом сам блок.
Если в блоке несколько заливок, то порядок их взаимного следования не имеет значения, за исключением случая присутствия заливки SOLID.
В этом случае заливка SOLID помещается на задний план в последнюю очередь (т.е. ниже всех объектов блока, в том числе других заливок)

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

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

[AlexV]

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"

[Кочетков Андрей]

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

• на задний план отправляются заливки
• на самый задний план отправляется wipeout

AlexV, не работает прога.
И даже ничего в комстроке не пишет.

[AlexV]

Сообщение от Кочетков Андрей ...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

Код, может, корявый, но у меня работает...

[VVA]

Вот реализация на 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]

Немного изменил код в #6. Что и куда посылать сделано ввиде опций функции hatch-to-back, т.к. в своей работе мне нужно, чтобы wipeout был там где я его поставил.

[Eddicordo]

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

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

Акад 2010 рус
Может чего я не понял???

[Do$]

Сообщение от Eddicordo Команда: H2B _.regenall Выполняется регенерация модели. Команда: nil

Все нормально. Судя по коду, так и должно быть. Все WIPEOUT и HATCH при этом в блоках должны переместиться на задний план.

[Nike]

Сообщение от 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 нет в системном реестре

Не подскажете, в чем дело и как это вылечить? Спасибо!

[VVA]

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

----- добавлено через ~4 мин. -----
И вот еще нашел. Dictionary error

[kosmi]

Великолепная штука, 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