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

wchsunshine · 发表于 2013-7-26 22:17:59

本帖最后由 wchsunshine 于 2022-3-12 22:08 编辑

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

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

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

逸帆6389 · 发表于 2024-11-16 12:54:24

5楼的问题可以解决，但最大问题是只能选择单个图块，如果能框选或者全选ALL就完美了，。如果再加上线型比例控制那就更更更完美了
哪位大师优化一下？

guankuiwu · 发表于 2022-6-1 11:19:19

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

wchsunshine · 发表于 2013-7-27 13:19:35

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

wchsunshine · 发表于 2013-7-28 21:07:23

坐等回复。。。。

Andyhon · 发表于 2013-7-28 21:15:17

坐等回复。。。。

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

前生 · 发表于 2013-7-28 21:54:15

;;;--------------------------------------
;;; 变块中的线型       ;;;;;;;;;;;;;
;;;--------------------------------------
(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 · 发表于 2013-7-29 20:46:22

测试了不行。。。

wchsunshine · 发表于 2013-7-29 21:08:14

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

wchsunshine · 发表于 2013-8-1 19:49:22

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

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

前生 · 发表于 2013-8-2 16:25:28

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

wchsunshine · 发表于 2013-8-3 19:43:12

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

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

[讨论] 求高手帮忙块内线型修改lisp

本帖子中包含更多资源

[讨论] 求高手帮忙 块内线型修改lisp

本帖子中包含更多资源

[讨论] 求高手帮忙块内线型修改lisp