求高手帮忙 块内线型修改lisp

wchsunshine

求lisp   实现功能：   将修改前中块内所有线变为双点画线， （主要为了在画图的时候方面使用） ， 实现结果见修改后。

希望都过lisp或其它程序来快速实现。

以前基本都过以下实现（1、要不就把块炸开了，即可随意修改线型，之后想成组再成组2、要不就双击进入块编辑器，在编辑器里面改好线型之后再退出编辑器，确认保存即可
这2个方法太麻烦不方便使用）
                    

guankuiwu

5楼给的已经很好了。可以自己改改，如果能再加上实时调线形比例就好了

wchsunshine

期待高手帮忙看下 ， 谢谢！

wchsunshine

坐等回复。。。。

Andyhon

坐等回复。。。。

还不如换跑道...
http://bbs.mjtd.com/thread-100603-1-1.html
若发帖者的目的仅仅是为求编写程序，则请到论坛“编程申请”板块发帖，不得在本版发布悬赏求程序贴

前生

;;;--------------------------------------
;;;    变块中的线型         ;;;;;;;;;;;;;
;;;--------------------------------------
(defun c:cbl (/ test en bn llis el ola la lent en count)
  (DEFUN CBL1 ()
    (if        (or
          (eq (cdr (assoc 0 (entget bn))) "DIMENSION")
          (eq (cdr (assoc 0 (entget bn))) "INSERT")
        )
      (setq test nil)
      (prompt "\n 未选中块实体:,请重新选取!")
    )
    (setq en  (car en)
          el  (entget en)
          ola (assoc 8 el)
    )
    (setq la (getstring "请输入新的线型< BYLAYER >"))
    (IF        (OR (NULL LA) (= "" LA))
      (SETQ LA "BYLAYER")
    )
    (IF        (ASSOC 6 EL)
      (setq el (subst (cons 6 la) (assoc 6 el) el)
            el (entmod el)
      )
      (setq el (append (list (Cons 6 la)) el)
            el (entmod el)
      )
    )
    (ENTUPD BN)
    (SETQ LENT (SSGET "X" (LIST (ASSOC 0 LLIS) (ASSOC 2 LLIS))))
    (SETQ COUNT 0)
    (IF        LENT
      (WHILE (< COUNT (SSLENGTH LENT))
        (setq EN (ssname LENT COUNT))
;;;        (SETQ ED (ENTGET EN))
;;;        (ENTMOD eN)
        (ENTUPD eN)
        (SETQ COUNT (1+ COUNT))
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (DEFUN CBL2 ()
    (setq la (getstring "请输入新的线型< BYLAYER >"))
    (IF        (OR (NULL LA) (= "" LA))
      (SETQ LA "BYLAYER")
    )
    (SETQ EN (CAR EN)
          EL (ENTGET EN)
    )
    (IF        (ASSOC 6 EL)
      (setq el (subst (cons 6 la) (assoc 6 el) el)
            el (entmod el)
      )
      (setq el (append (list (Cons 6 la)) el)
            el (entmod el)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq en nil)
  (setq test T)
  (setq en (nentselp "\n请选取块中实体"))
  (if en
    (if        (= 2 (length en))
      (progn
        (prompt "所指的是块的属性或单个的实体!:")
        (setq test nil)
        (CBL2)
      )
    )
  )
  (if test
    (progn
      (setq bn         (car (nth 3 en))
            LLIS (ENTGET BN)
      )
      (CBL1)
    )
  )
  (SETQ CBL1 NIL)
  (SETQ CBL2 NIL)
  (princ)
)

wchsunshine

测试了   不行。。。

wchsunshine

我希望框选之后，块内所有的线都变成双点画线。。。       这样画图操作方便

wchsunshine

先谢谢5楼了   ，麻烦5楼的再帮忙看看，程序测试了下，程序提示：请输入新的线型后，输入center  ，输入的新的线型只能更改块内的某一个线的线型，不能将块内所有的线的线型改为新设置的线型。

希望：如   "请输入新的线型< BYLAYER >"         改成（1、BYLAYER   2、双点化线、3、虚线） 这种可选择输入1、  2、  3输入话 的话就相当好了

前生

全部变的话，二个方法。
1:遍历块中实体，变线型
2：求得块的插入点，炸碎，变线型，重生成同名块。

wchsunshine

就是不想通过  
以下实现（
1、要不就把块炸开了，即可随意修改线型，之后想成组再成组
2、要不就双击进入块编辑器，在编辑器里面改好线型之后再退出编辑器，确认保存即可
这2个方法太麻烦不方便使用）
想通过高手lisp直接实现