菜卷鱼 发表于 2015-9-25 16:52:46

快速建块，仍然有BUG

本帖最后由 菜卷鱼 于 2015-11-4 22:20 编辑

BUG太多了，能力不足，搞不定，还需要进一步学习，以下代码仅供参考，、使用的话导致CAD死机甚至电脑死机自己负责啊

;;;;快速建块，花了两天时间，还是半成品。
;;;;建属性块时可能会出错，还可能有N多BUG
;;;;希望有人出手优化一下
;;;;建普通块是没问题的

(defun attblock (objs / obj info )
(setq info (entget objs))
(entmake(infodel info '(-1 330 5 )))
(setq obj (entnext objs))
(setq info (entget obj))
(while
(equal '(0 . "ATTRIB") ( assoc 0 info))
(entmake (infodel info '(-1 330 5 )))
(setq obj (entnext obj))
(setq info (entget obj)))
(entmake (list
    '(0 . "SEQEND")
    '(100 . "AcDbEntity")
    '(67 . 0)
    '(8 . "0")
      )
   )
)
(defun infodel (elist num)
   (last(mapcar '(lambda(x)
       (setq elist(vl-remove(assoc x elist)elist))
       )
      num
    )
)
)
(defun ribdef ( info / elist)
(setq elist info
      elist (subst '(0 . "ATTRIB")'(0 . "ATTDEF")elist)
      elist (subst '(100 . "AcDbAttribute")'(100 . "AcDbAttributeDefinition") elist))
(last (mapcar '(lambda(x)
       (setq elist(vl-remove(assoc x elist)elist))
       )
    '(-1 330 5 3 410 )
    )
)
)
(defun UndoBe ()   ;;;;; undo begin
    (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)

(defun UndoE ()   ;;;;; undo end
    (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)

(DEFUN C:Qq( /*error* ss pt nn i ssattdefinfo )
(princ "Quick Block")
(defun *error* (s)
(if (/= s "取消")(undoe))
)
(setq      ss (ssget)
      nn (rtos(getvar 'cdate) 2 8)
      pt (getvar 'viewctr)
      ssattdef (ssadd))
(UndoBe)
(entmake (list
    '(0 . "BLOCK")
    '(100 . "AcDbEntity")
    '(67 . 0)
    '(8 . "0")
    '(100 . "AcDbBlockBegin")
    '(70 . 2)
    '(1 . "")
    (cons 10 pt)
    (cons 2 nn)
      )
    )
(repeat (setq i (sslength ss))
(setq obj (ssname ss (setq i (1- i)))
      info (entget obj))
(cond
((equal '(0 . "ATTDEF") ( assoc 0 info))
          (setq ssattdef (ssadd obj ssattdef)) (entmake (infodel info '(-1 330 5 410)) ) )
((equal '(66 . 1)
          ( assoc 66 info)) (attblock obj))
(T       (entmake (infodel info '(-1 330 5 410))) )
);;;end cond
);;;end repeat
(entmake (list
    '(0 . "ENDBLK")
    '(100 . "AcDbEntity")
    '(100 . "AcDbBlockEnd")
   )
)
(entupd (tblobjname "Block" nn))
(if(zerop (sslength ssattdef))
(entmake (list '(0 . "insert") (cons 2 nn) (cons 10 pt)))
(progn
(entmake (list '(0 . "insert") (cons 2 nn) (cons 10 pt) '(66 . 1)))
(repeat(setq i (sslength ssattdef))
(entmake (ribdef(entget (ssname ssattdef (setq i (1- i))))))
         )   ;;;end repeat   
));;;end progn if
(entmake '((0 . "SEQEND")))
(repeat (setq i (sslength ss))
    (entdel (ssname ss (setq i (1- i)))))
(UndoE)
(princ (strcat "\nCreated Block " nn))
(PRIN1))
(prin1)

;;;;

菜卷鱼 发表于 2015-9-26 22:58:51

本帖最后由 菜卷鱼 于 2015-11-4 22:21 编辑

把没有子图元的图元建成块应该没问题的，其它的复杂点的块问题搞不定

lucas_3333 发表于 2015-9-26 23:18:06

菜卷鱼 发表于 2015-9-26 22:58 static/image/common/back.gif
其实我已经搞出没BUG的了，看没人回帖，就不发了

呵呵，可能大家都过节去了！不要那么辛苦 ，节日要多放松放松
另外论坛快速建块的贴子蛮多的，以时间做块名， 形心做基点，等等，
你说有N多BUG， 具体是哪些？也没说清楚，高手们也不好怎么解答，

峰峰兒 发表于 2015-9-28 07:47:54

yhly555 发表于 2015-10-25 10:48:30

菜卷鱼 发表于 2015-9-26 22:58 static/image/common/back.gif
其实我已经搞出没BUG的了，看没人回帖，就不发了

看来楼主是位高手，写程序都不用加注释，能发个没有BUG的出来共享一下不？谢谢！

hbgsw 发表于 2015-10-25 14:13:20

楼主功底很深厚，MARK,在慢慢研究。。。

炸子鸡 发表于 2015-10-28 08:55:39

回帖呢，是什么快捷键？

米兰达薇薇2899 发表于 2015-11-4 15:22:50

菜卷鱼 发表于 2015-9-26 22:58 static/image/common/back.gif
其实我已经搞出没BUG的了，看没人回帖，就不发了

选择对象:; 错误: *error* 函数中出错无函数定义: VLAX-GET-ACAD-OBJECT

米兰达薇薇2899 发表于 2015-11-4 15:23:31

不能用啊，楼主

woistc 发表于 2015-11-4 21:17:34

C:\asd.gif
页: [1] 2
查看完整版本: 快速建块，仍然有BUG