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

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

本帖最后由 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直接实现
页: [1] 2
查看完整版本: 求高手帮忙 块内线型修改lisp