AUTOLISP转成VLISP代码

artken · 发表于 2008-8-13 16:56

本帖最后由 artken 于 2011-3-20 04:38 编辑

下面是ET工具里的分解属性块BURST命令（用AUTOLISP写的），作了点修改（改成是加载后自动选物体执行了）。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;以下是函数定义;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun PBOBURST (/ item bitset bump att-text lastent burst-one burst
BCNT BLAYER BCOLOR ELAST BLTYPE ETYPE PSFLAG ENAME )
;-----------------------------------------------------
; Item from association list
;-----------------------------------------------------
(Defun ITEM (N E) (CDR (Assoc N E)))
;-----------------------------------------------------
; Error Handler
;-----------------------------------------------------
(acet-error-init
(list
(list "cmdecho" 0
"highlight" 1
)
T ;flag. True means use undo for error clean up.
);list
);acet-error-init
;-----------------------------------------------------
; BIT SET
;-----------------------------------------------------
(Defun BITSET (A B) (= (Boole 1 A B) B))
;-----------------------------------------------------
; BUMP
;-----------------------------------------------------
(Setq bcnt 0)
(Defun bump (prmpt)
(Princ
(Nth bcnt '("\r-" "\r\" "\r|" "\r/"))
)
(Setq bcnt (Rem (1+ bcnt) 4))
)
;-----------------------------------------------------
; Convert Attribute Entity to Text Entity
;-----------------------------------------------------
(Defun ATT-TEXT (AENT / TENT ILIST INUM)
(Setq TENT '((0 . "TEXT")))
(ForEach INUM '(8
6
38
39
62
67
210
10
40
1
50
41
51
7
71
72
73
11
74
)
(If (Setq ILIST (Assoc INUM AENT))
(Setq TENT (Cons ILIST TENT))
)
)
(Setq
tent (Subst
(Cons 73 (item 74 aent))
(Assoc 74 tent)
tent
)
)
(EntMake (Reverse TENT))
)
;-----------------------------------------------------
; Find True last entity
;-----------------------------------------------------
(Defun LASTENT (/ E0 EN)
(Setq E0 (EntLast))
(While (Setq EN (EntNext E0))
(Setq E0 EN)
)
E0
)
;-----------------------------------------------------
; Burst one entity
;-----------------------------------------------------
(Defun BURST-ONE (BNAME / BENT ANAME ENT ATYPE AENT AGAIN ENAME
ENT SS-COLOR SS-LAYER SS-LTYPE mirror ss-mirror
mlast)
(Setq
BENT (EntGet BNAME)
BLAYER (ITEM 8 BENT)
BCOLOR (ITEM 62 BENT)
BCOLOR (Cond
((> BCOLOR 0) BCOLOR)
((= BCOLOR 0) "BYBLOCK")
("BYLAYER")
)
BLTYPE (Cond ((ITEM 6 BENT)) ("BYLAYER"))
)
(Setq ELAST (LASTENT))
(If (= 1 (ITEM 66 BENT))
(Progn
(Setq ANAME BNAME)
(While (Setq
ANAME (EntNext ANAME)
AENT (EntGet ANAME)
ATYPE (ITEM 0 AENT)
AGAIN (= "ATTRIB" ATYPE)
)
(bump "正在转换属性")
(ATT-TEXT AENT)
)
)
)
(Progn
(bump "分解块")
(acet-explode BNAME)
;(vla-explode (vlax-ename->vla-object BNAME))
;(command "_.explode" bname)
)
(Setq
SS-LAYER (SsAdd)
SS-COLOR (SsAdd)
SS-LTYPE (SsAdd)
ENAME ELAST
)
(While (Setq ENAME (EntNext ENAME))
(bump "收集片")
(Setq
ENT (EntGet ENAME)
ETYPE (ITEM 0 ENT)
)
(If (= "ATTDEF" ETYPE)
(Progn
(If (BITSET (ITEM 70 ENT) 2)
(ATT-TEXT ENT)
)
(EntDel ENAME)
)
(Progn
(If (= "0" (ITEM 8 ENT))
(SsAdd ENAME SS-LAYER)
)
(If (= 0 (ITEM 62 ENT))
(SsAdd ENAME SS-COLOR)
)
(If (= "BYBLOCK" (ITEM 6 ENT))
(SsAdd ENAME SS-LTYPE)
)
)
)
)
(If (> (SsLength SS-LAYER) 0)
(Progn
(bump "固定图层")
(Command
"_.chprop" SS-LAYER "" "_LA" BLAYER ""
)
)
)
(If (> (SsLength SS-COLOR) 0)
(Progn
(bump "固定颜色")
(Command
"_.chprop" SS-COLOR "" "_C" BCOLOR ""
)
)
)
(If (> (SsLength SS-LTYPE) 0)
(Progn
(bump "固定线型")
(Command
"_.chprop" SS-LTYPE "" "_LT" BLTYPE ""
)
)
)
)
;-----------------------------------------------------
; BURST MAIN ROUTINE
;-----------------------------------------------------
(Defun BURST (/ SS1)
(setq PSFLAG (if (= 1 (caar (vports)))
1 0
)
)
(pbossget);;;;自动选择要分解的物体
(If SS1
(Progn
(Setvar "highlight" 0)
(terpri)
(Repeat
(SsLength SS1)
(Setq ENAME (SsName SS1 0))
(SsDel ENAME SS1)
(BURST-ONE ENAME)
)
(princ "\n")
)
)
)
;-----------------------------------------------------
; BURST COMMAND
;-----------------------------------------------------
(BURST)
(acet-error-restore)
);end defun
(princ)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;函数定义完毕;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;第一步:分解属性块
(princ "{开始分解属性块，耐心等待...}")
(defun pbossget ()
(Setq SS1 (SsGet "X" (list (cons 0 "INSERT")'(66 . 1)(cons 67 PSFLAG))));;分解所有带属性块
)
(PBOBURST)
(command ".-PURGE" "A" "" "N")
;;;;;;;;;;;;;;
(defun pbossget ()
(Setq SS1 (SsGet "X" (list (cons 0 "INSERT")'(2 . "`*U*")(cons 67 PSFLAG))));;分解所有无名块(在CAD2004里执行，动态块转为CAD2004后自动会变成匿名块)
)
(PBOBURST)
;;;;;;;;;;;;;;
(princ "{属性块分解完毕}准备进入下一步，耐心等待...=====》")
(princ)
;;;第二步:炸开动态块(在CAD2004里略去)
;;;第三步:炸开多重引线(在CAD2004里执行，CAD2008的多重引线转成CAD2004后自动变成ACAD_PROXY_ENTITY)
(setvar "qaflags" 1)
(if (/= (SsGet "X" '((0 . "ACAD_PROXY_ENTITY"))) nil)
(command "._explode" (SsGet "X" '((0 . "ACAD_PROXY_ENTITY"))) "")
(princ "选择集为空")
)
(setvar "qaflags" 0)
(command ".-PURGE" "A" "" "N")
(princ "{多重引线分解完毕，耐心等待...}=====》")
(princ)
(command ".-PURGE" "A" "" "N")
(princ "{垃圾清理完毕!}")
(princ)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;以下是函数定义;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(Defun PBOBURST (/ item bitset bump att-text lastent burst-one burst 
                  BCNT BLAYER BCOLOR ELAST BLTYPE ETYPE PSFLAG ENAME ) 
   ;----------------------------------------------------- 
   ; Item from association list 
   ;----------------------------------------------------- 
   (Defun ITEM (N E) (CDR (Assoc N E))) 
   ;----------------------------------------------------- 
   ; Error Handler 
   ;----------------------------------------------------- 
  (acet-error-init 
    (list 
      (list "cmdecho" 0 
            "highlight" 1 
      ) 
      T     ;flag. True means use undo for error clean up. 
    );list 
  );acet-error-init 
   ;----------------------------------------------------- 
   ; BIT SET 
   ;----------------------------------------------------- 
   (Defun BITSET (A B) (= (Boole 1 A B) B)) 
   ;----------------------------------------------------- 
   ; BUMP 
   ;----------------------------------------------------- 
   (Setq bcnt 0) 
   (Defun bump (prmpt) 
      (Princ 
         (Nth bcnt '("\r-" "\r\" "\r|" "\r/")) 
      ) 
      (Setq bcnt (Rem (1+ bcnt) 4)) 
   ) 
   ;----------------------------------------------------- 
   ; Convert Attribute Entity to Text Entity 
   ;----------------------------------------------------- 
   (Defun ATT-TEXT (AENT / TENT ILIST INUM) 
      (Setq TENT '((0 . "TEXT"))) 
      (ForEach INUM '(8 
            6 
            38 
            39 
            62 
            67 
            210 
            10 
            40 
            1 
            50 
            41 
            51 
            7 
            71 
            72 
            73 
            11 
            74 
         ) 
         (If (Setq ILIST (Assoc INUM AENT)) 
            (Setq TENT (Cons ILIST TENT)) 
         ) 
      ) 
      (Setq 
         tent (Subst 
                 (Cons 73 (item 74 aent)) 
                 (Assoc 74 tent) 
                 tent 
              ) 
      ) 
      (EntMake (Reverse TENT)) 
   ) 
   ;----------------------------------------------------- 
   ; Find True last entity 
   ;----------------------------------------------------- 
   (Defun LASTENT (/ E0 EN) 
      (Setq E0 (EntLast)) 
      (While (Setq EN (EntNext E0)) 
         (Setq E0 EN) 
      ) 
      E0 
   ) 
   ;----------------------------------------------------- 
   ; Burst one entity 
   ;----------------------------------------------------- 
   (Defun BURST-ONE (BNAME / BENT ANAME ENT ATYPE AENT AGAIN ENAME 
                     ENT SS-COLOR SS-LAYER SS-LTYPE mirror ss-mirror 
                     mlast) 
      (Setq 
         BENT   (EntGet BNAME) 
         BLAYER (ITEM 8 BENT) 
         BCOLOR (ITEM 62 BENT) 
         BCOLOR (Cond 
                   ((> BCOLOR 0) BCOLOR) 
                   ((= BCOLOR 0) "BYBLOCK") 
                   ("BYLAYER") 
                ) 
         BLTYPE (Cond ((ITEM 6 BENT)) ("BYLAYER")) 
      ) 
      (Setq ELAST (LASTENT)) 
      (If (= 1 (ITEM 66 BENT)) 
         (Progn 
            (Setq ANAME BNAME) 
            (While (Setq 
                      ANAME (EntNext ANAME) 
                      AENT  (EntGet ANAME) 
                      ATYPE (ITEM 0 AENT) 
                      AGAIN (= "ATTRIB" ATYPE) 
                   ) 
               (bump "正在转换属性") 
               (ATT-TEXT AENT) 
            ) 
         ) 
      ) 
         (Progn 
            (bump "分解块") 
            (acet-explode BNAME) 
            ;(vla-explode (vlax-ename->vla-object BNAME)) 
            ;(command "_.explode" bname) 
         ) 
      (Setq 
         SS-LAYER (SsAdd) 
         SS-COLOR (SsAdd) 
         SS-LTYPE (SsAdd) 
         ENAME    ELAST 
      ) 
      (While (Setq ENAME (EntNext ENAME)) 
         (bump "收集片") 
         (Setq 
            ENT   (EntGet ENAME) 
            ETYPE (ITEM 0 ENT) 
         ) 
         (If (= "ATTDEF" ETYPE) 
            (Progn 
               (If (BITSET (ITEM 70 ENT) 2) 
                  (ATT-TEXT ENT) 
               ) 
               (EntDel ENAME) 
            ) 
            (Progn 
               (If (= "0" (ITEM 8 ENT)) 
                  (SsAdd ENAME SS-LAYER) 
               ) 
               (If (= 0 (ITEM 62 ENT)) 
                  (SsAdd ENAME SS-COLOR) 
               ) 
               (If (= "BYBLOCK" (ITEM 6 ENT)) 
                  (SsAdd ENAME SS-LTYPE) 
               ) 
            ) 
         ) 
      ) 
      (If (> (SsLength SS-LAYER) 0) 
         (Progn 
            (bump "固定图层") 
            (Command 
               "_.chprop" SS-LAYER "" "_LA" BLAYER "" 
            ) 
         ) 
      ) 
      (If (> (SsLength SS-COLOR) 0) 
         (Progn 
            (bump "固定颜色") 
            (Command 
               "_.chprop" SS-COLOR "" "_C" BCOLOR "" 
            ) 
         ) 
      ) 
      (If (> (SsLength SS-LTYPE) 0) 
         (Progn 
            (bump "固定线型") 
            (Command 
               "_.chprop" SS-LTYPE "" "_LT" BLTYPE "" 
            ) 
         ) 
      ) 
   ) 
   ;----------------------------------------------------- 
   ; BURST MAIN ROUTINE 
   ;----------------------------------------------------- 
   (Defun BURST (/ SS1) 
      (setq PSFLAG (if (= 1 (caar (vports))) 
                       1 0 
                   ) 
      ) 
 
      (pbossget);;;;自动选择要分解的物体 
      (If SS1 
         (Progn 
            (Setvar "highlight" 0) 
            (terpri) 
            (Repeat 
               (SsLength SS1) 
               (Setq ENAME (SsName SS1 0)) 
               (SsDel ENAME SS1) 
               (BURST-ONE ENAME) 
            ) 
            (princ "\n") 
         ) 
      ) 
   ) 
   ;----------------------------------------------------- 
   ; BURST COMMAND 
   ;----------------------------------------------------- 
   (BURST) 
  (acet-error-restore) 
);end defun 
(princ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;函数定义完毕;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;第一步:分解属性块 
(princ "{开始分解属性块，耐心等待...}") 
(defun pbossget () 
   (Setq SS1 (SsGet "X" (list (cons 0 "INSERT")'(66 . 1)(cons 67 PSFLAG))));;分解所有带属性块 
) 
(PBOBURST) 
(command ".-PURGE" "A" "" "N") 
;;;;;;;;;;;;;; 
(defun pbossget () 
   (Setq SS1 (SsGet "X" (list (cons 0 "INSERT")'(2 . "`*U*")(cons 67 PSFLAG))));;分解所有无名块(在CAD2004里执行，动态块转为CAD2004后自动会变成匿名块) 
) 
(PBOBURST) 
;;;;;;;;;;;;;; 
(princ "{属性块分解完毕}准备进入下一步，耐心等待...=====》") 
(princ) 
;;;第二步:炸开动态块(在CAD2004里略去) 
;;;第三步:炸开多重引线(在CAD2004里执行，CAD2008的多重引线转成CAD2004后自动变成ACAD_PROXY_ENTITY) 
(setvar "qaflags" 1) 
(if (/= (SsGet "X" '((0 . "ACAD_PROXY_ENTITY"))) nil) 
    (command "._explode" (SsGet "X" '((0 . "ACAD_PROXY_ENTITY"))) "") 
    (princ "选择集为空") 
) 
(setvar "qaflags" 0) 
(command ".-PURGE" "A" "" "N") 
(princ "{多重引线分解完毕，耐心等待...}=====》") 
(princ) 
(command ".-PURGE" "A" "" "N") 
(princ "{垃圾清理完毕!}") 
(princ)

现在问题是：它只能对当前空间执行，比如当前是在模型空间就只处理模型空间的，不能处理图纸空间的。
根据龙龙仔的指点（感谢龙龙仔！），将程序转成VLISP写就可以实现跨空间处理，并且给出了其中一段炸图的例子，我试过了确实可以！可是除了炸图块外还要固定块的属性、颜色.....等等
龙龙仔帮忙写的部份在这里http://bbs.mjtd.com/forum.php?mod=viewthread&tid=69405

龙龙仔 · 发表于 2008-8-14 08:02

有測試的原始圖+完成圖嗎?

artken · 发表于 2008-8-14 11:56

龙龙仔，由于论坛对上传文件大小限制，我上传到别的地方了。下面这个网址

http://mail.qq.com/cgi-bin/exs_download?uin=78797789&svrid=229&fid=bb10bd2739c7edb2d6f3c370f4e9ad38ce28257961927cda&&txf_fid=b317a68c15e0c82244141e069b6c267917458f0c&&txf_sid=64c025f5e96a8b94d31c2e71d64c84f9f6d495f2&code=22d94b26&k=3e6c1c3083cd917f2c95c07f65644f326e3666338b3037308e3765396b643338372d73767966194b5743

龙龙仔 · 发表于 2008-8-15 07:56

本帖最后由作者于 2008-8-15 7:57:07 编辑

本想在R2008一次完成處理,但因"MULTILEADER"沒有explode方法,所以暫時無法解決,

(構想是先把其他空間的"MULTILEADER"轉到目前空間,處理完再轉回去)

巳完成了大部份(但目前沒有時間),把手上的部份先貼上

artken · 发表于 2008-8-15 09:49

本帖最后由作者于 2008-8-15 12:56:01 编辑

版主大人辛苦了！！！

========================

刚试用了

惊喜啊！没想到2008里能分解MULTILEADER！不用转到2004了。如果MULTILEADER也能跨空间处理就完美了。

artken · 发表于 2008-8-16 17:34

本帖最后由作者于 2008-8-16 17:46:25 编辑

龙龙仔，经过反复测试后，发现有个问题。

有时会提示"Automation 错误"而无法执行下去

为找出原因，试了上百次都不止，结果就是：

1、从文件方面：有些文件会但有些不会，出问题与不出问题的文件其实都是很类似的，里面用的块也都是那些，也不是因为某一个图块的问题，没个准。用原来没转成VLISP之前的程序就不会有这问题。

2、从程序方面，将以下2个地方修改了后就可以执行完，但处理后的结果就不同了....

(1)、将 (vla-explode (vlax-ename->vla-object BNAME)) 改为 (acet-explode BNAME)

(2)、将(vla-delete (vlax-ename->vla-object ENAME))这句删除。

在CAD2004与CAD2008下执行都存在这问题

上传了一个不能正常处理的文件：

龙龙仔 · 发表于 2008-8-18 12:40

本帖最后由作者于 2008-8-18 17:16:24 编辑

用VLISP炸圖塊"!YUQIANG_TK_A2"有問題!!原因不明,待查!!

龙龙仔 · 发表于 2008-8-19 12:27

查出來是圖塊"!YUQIANG_TK_A2",在圖面中的圖塊參考(blockref),與圖塊定義(blockdef)內容不同,即圖塊炸開後物件數量不同,原圖塊定義是"LWPOLYLINE"的物件,炸開後變成了"LINE",造成VLISP在炸開時出錯(但用COMMAND "_.EXPLODE"不會出錯),但是如何造成這現象,待查!

龙龙仔 · 发表于 2008-8-19 17:13

被你騙了,原來圖中"!YUQIANG_TK_A2"的blockref是不等比圖塊,vlisp不支持炸開不等比圖塊

(構想是先把其他空間的"MULTILEADER"轉到目前空間,處理完再轉回去)----巳完成

但我看出你是要把圖面弄亂,是嗎?

artken · 发表于 2008-8-19 19:56

啊，哪敢騙龍大人啊，哈哈。。不等比圖塊。。

這圖塊不是我弄，是個圖框，直接用以前現成的。不是要特地弄成不等比圖塊。回頭將圖塊重做試試.

MULTILEADER問題解決了？太棒了

我不是要將圖面弄亂啊。之所以要進行處理是因為：

1、多重引線：只有2008有，別人用2004打開的話，經常就會看不到這個多重引線的東西，以為是我圖紙沒標材料。分解後就不存在這問題了。

2、屬性塊、動態塊：因為有屬性，別人打開我的圖後，經常會自己莫名其妙（或不小心）用"X"炸有些圖塊。用"X"炸屬性塊就完蛋了，屬性都回複到最原始的狀態，顯然是不對的。所以要保留屬性分解。

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

[源码] AUTOLISP转成VLISP代码

本帖子中包含更多资源

本帖子中包含更多资源