求块内和非块内填充一次全部后置lisp

zippo11 · 发表于 2014-7-9 09:27:25

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

不是块内的填充后置当然有啦

(defun c:tchz ()
  (if (ssget "_x" '((0 . "HATCH")))
(command "_draworder" "p" "" "_b")
  )
  (command "regen")
  (princ)
)

但是块内的填充后置不会，求高手

zippo11 · 发表于 2014-7-9 10:20:41

变世界难题了。

st788796 · 发表于 2014-7-9 11:22:04

本帖最后由 st788796 于 2014-7-9 11:45 编辑

没有测试，大致思路

(defun c:tt (/ blkdef blkdefents ss)
(setq blkdef (vl-remove-if
'(lambda (x)
(wcmatch (car x) "`**_Space*")
)
(XD::Object:Get "Block")
)
blkdefents (vl-remove
nil
(mapcar
'(lambda (x)
(vl-remove-if-not
'(lambda (a)
(wcmatch (xdrx_getpropertyvalue a "IsA")
"*HATCH"
)
)
(xdrx_getpropertyvalue x "AllEntities")
)
)
blkdef
)
)
)
(if (setq ss (ssget "x" '((0 . "hatch"))))
(apply 'xdrx_draworder->back
(append (list ss) (apply 'append blkdefents))
)
(if blkdefents
(apply 'xdrx_draworder->back (apply 'append blkdefents))
)
)
(princ)
)

(defun c:tt (/ blkdef blkdefents ss) 
  (setq        blkdef           (vl-remove-if 
                     '(lambda (x) 
                        (wcmatch (car x) "`**_Space*") 
                      ) 
                     (XD::Object:Get "Block") 
                   ) 
        blkdefents (vl-remove 
                     nil 
                     (mapcar 
                       '(lambda        (x) 
                          (vl-remove-if-not 
                            '(lambda (a) 
                               (wcmatch        (xdrx_getpropertyvalue a "IsA") 
                                        "*HATCH" 
                               ) 
                             ) 
                            (xdrx_getpropertyvalue x "AllEntities") 
                          ) 
                        ) 
                       blkdef 
                     ) 
                   ) 
  ) 
  (if (setq ss (ssget "x" '((0 . "hatch")))) 
    (apply 'xdrx_draworder->back 
           (append (list ss) (apply 'append blkdefents)) 
    ) 
    (if        blkdefents 
      (apply 'xdrx_draworder->back (apply 'append blkdefents)) 
    ) 
  ) 
  (princ) 
)

清风明月10 · 发表于 2014-7-10 09:08:27

谢谢楼主分享，辛苦了！
还是希望所有人发的代码都经过调试的才好。一是自己发无法运行的代码，心内也会产生挫折感的。二是，一人不调试，却造成多数下载试用的人不知所措。

zippo11 · 发表于 2014-7-17 14:59:16

st788796 发表于 2014-7-9 11:22
没有测试，大致思路

测试可以用吗？

牢固 · 发表于 2014-7-17 15:51:03

;;块内填充对象置后,CAD2005以上版本适用 By Gu_xl 2014.07.17
(defun c:tt (/ en sortents dict blockdef lst Doc)
(if (and (setq en (car (entsel "\n选择块:")))
(= "INSERT" (cdr (assoc 0 (setq en (entget en)))))
)
(progn
(cond
(
(not
(VL-CATCH-ALL-ERROR-P
(setq sortents
(VL-CATCH-ALL-APPLY
'vla-item
(list
(setq dict
(vla-GetExtensionDictionary
(setq blockdef
(vla-item
(vla-get-blocks
(setq doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
(cdr (assoc 2 en))
)
)
)
)
"ACAD_SORTENTS"
)
)
)
)
)
)
((setq sortents
(VL-CATCH-ALL-APPLY
'vla-AddObject
(list dict "ACAD_SORTENTS" "AcDbSortentsTable")
)
)
)
)
(vlax-for obj blockdef
(if (= "AcDbHatch" (vla-get-objectname obj))
(setq lst (cons obj lst))
)
)
(if lst
(progn
(vla-MoveToBottom
sortents
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length lst)))
)
lst
)
)
)
(vla-regen doc :vlax-true)
)
)
)
)
(princ)
)

;;块内填充对象置后,CAD2005以上版本适用 By Gu_xl 2014.07.17 
(defun c:tt (/ en sortents dict blockdef lst Doc) 
  (if (and (setq en (car (entsel "\n选择块:"))) 
     (= "INSERT" (cdr (assoc 0 (setq en (entget en))))) 
      ) 
    (progn 
      (cond 
  ( 
   (not 
     (VL-CATCH-ALL-ERROR-P 
       (setq sortents 
        (VL-CATCH-ALL-APPLY 
          'vla-item 
          (list 
      (setq dict 
             (vla-GetExtensionDictionary 
         (setq blockdef 
          (vla-item 
            (vla-get-blocks 
              (setq doc 
               (vla-get-ActiveDocument 
                 (vlax-get-acad-object) 
               ) 
              ) 
            ) 
            (cdr (assoc 2 en)) 
          ) 
         ) 
             ) 
      ) 
      "ACAD_SORTENTS" 
          ) 
        ) 
       ) 
     ) 
   ) 
  ) 
  ((setq sortents 
    (VL-CATCH-ALL-APPLY 
      'vla-AddObject 
      (list dict "ACAD_SORTENTS" "AcDbSortentsTable") 
    ) 
   ) 
  ) 
      ) 
      (vlax-for  obj blockdef 
  (if (= "AcDbHatch" (vla-get-objectname obj)) 
    (setq lst (cons obj lst)) 
  ) 
      ) 
      (if lst 
  (progn 
    (vla-MoveToBottom 
      sortents 
      (vlax-make-variant 
        (vlax-safearray-fill 
    (vlax-make-safearray 
      vlax-vbobject 
      (cons 0 (1- (length lst))) 
    ) 
    lst 
        ) 
      ) 
    ) 
    (vla-regen doc :vlax-true) 
  ) 
      ) 
    ) 
  ) 
  (princ) 
)

zippo11 · 发表于 2014-7-17 17:11:29

牢固发表于 2014-7-17 15:51

能不能不选择，一个命令所有填充后置？

牢固 · 发表于 2014-7-17 18:40:12

zippo11 发表于 2014-7-17 17:11
能不能不选择，一个命令所有填充后置？

;;一键所有填充对象置后显示,CAD2005以上版本适用 By Gu_xl 2014.07.17
(defun c:tt1 (/ sortents dict lst Doc)
(setq doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
(vlax-for blockdef (vla-get-blocks doc)
(cond
(
(not
(VL-CATCH-ALL-ERROR-P
(setq sortents
(VL-CATCH-ALL-APPLY
'vla-item
(list
(setq dict
(vla-GetExtensionDictionary
blockdef
)
)
"ACAD_SORTENTS"
)
)
)
)
)
)
((setq sortents
(VL-CATCH-ALL-APPLY
'vla-AddObject
(list dict "ACAD_SORTENTS" "AcDbSortentsTable")
)
)
)
)
(setq lst nil)
(vlax-for obj blockdef
(if (= "AcDbHatch" (vla-get-objectname obj))
(setq lst (cons obj lst))
)
)
(if lst
(progn
(vla-MoveToBottom
sortents
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length lst)))
)
lst
)
)
)
)
)
)
(vla-regen doc :vlax-true)
(princ)
)

;;一键所有填充对象置后显示,CAD2005以上版本适用 By Gu_xl 2014.07.17 
(defun c:tt1 (/ sortents dict  lst Doc) 
  (setq  doc 
   (vla-get-ActiveDocument 
     (vlax-get-acad-object) 
   ) 
  ) 
  (vlax-for blockdef (vla-get-blocks doc) 
    (cond 
      ( 
       (not 
   (VL-CATCH-ALL-ERROR-P 
     (setq sortents 
      (VL-CATCH-ALL-APPLY 
        'vla-item 
        (list 
          (setq dict 
           (vla-GetExtensionDictionary 
             blockdef 
           ) 
          ) 
          "ACAD_SORTENTS" 
        ) 
      ) 
     ) 
   ) 
       ) 
      ) 
      ((setq sortents 
        (VL-CATCH-ALL-APPLY 
    'vla-AddObject 
    (list dict "ACAD_SORTENTS" "AcDbSortentsTable") 
        ) 
       ) 
      ) 
    ) 
    (setq lst nil) 
    (vlax-for obj blockdef 
      (if (= "AcDbHatch" (vla-get-objectname obj)) 
  (setq lst (cons obj lst)) 
      ) 
    ) 
    (if  lst 
      (progn 
  (vla-MoveToBottom 
    sortents 
    (vlax-make-variant 
      (vlax-safearray-fill 
        (vlax-make-safearray 
    vlax-vbobject 
    (cons 0 (1- (length lst))) 
        ) 
        lst 
      ) 
    ) 
  ) 
 
      ) 
    ) 
  ) 
  (vla-regen doc :vlax-true) 
  (princ) 
)

zippo11 · 发表于 2014-7-18 09:40:25

牢固发表于 2014-7-17 18:40

{:soso_e179:}

longer1000 · 发表于 2016-9-23 20:21:09

G版牛上天呢

账号		自动登录	找回密码
密码			立即注册

[求助] 求块内和非块内填充一次全部后置lisp

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评

点评