《剪切成虚线》v3.1版(支持框选)
本帖最后由 langjs 于 2020-9-1 10:27 编辑很久以前就想实现的一个功能，终于实现了：
我们制图时在画被遮挡的虚线时，通常是先剪切，再重新画上被遮挡的线，然后再变为虚线，操作复杂。
本程序的目的是鼠标移动到目标时，自动剪切为虚线。
程序支持直线、圆、圆弧，对多段线支持不算太完美。
升级历史：2018年10月：初始版1.0版因为调用了大量剪切命令，使得程序有些卡顿。
2018年11月：升级为2.0版采用entmak方式解决卡涩问题，解决部分Bug
2020年03月：升级为3.0版增加框选功能。
2020年08月：升级为3.1版修正为屏幕外可选。
;;; ================================
;;; 《剪切成虚线》v3.10(支持框选)
;;; 功能：将直线、圆、圆弧剪切成虚线
;;; 使用：选择到目标左键确认右键删除
;;; a,s键调整虚线线型比例
;;; 未选择到目标时右键退出程序
;;;by:langjs 2020.8.28
;;; ================================
**** Hidden Message *****
本帖最后由 lxl217114 于 2020-8-28 14:40 编辑
谢谢楼主再次更新
不知道是什么缘固，这次更新也是加载即报错，不能使用。
提示如下：
命令: ap APPLOAD 已成功加载 剪切成虚线v3.10.lsp。
命令: ; 错误: 输入中的点位置不正确
2020.08.28 14：39-------------------------------------------------------------
找会写代码的朋友看了，并调整了一下
终于好使了
再次感谢 lang 大师
在这里借 lang 大师的花献佛
好东西要支持一下 gcho 发表于 2018-11-5 11:09
测试很强大，可以解决这种问题吗，已知直线AC，B点为直线AC的中点，想把另一条直线BC改为虚线，同时裁剪删 ...
这个有啥用呢？有源码了很容易就改出来
(defun c:qq ( / code en ent gr i loop name nearpt p0 p1 p2 pd pdlst pt ss x)
(defun sub (i x ent)
(subst(cons i x)(assoc i ent) ent))
(setvar "cmdecho" 0)
(if (null (tblsearch "ltype" "DASHED")) (command "-linetype" "L" "DASHED" "" ""))
(if (= (tblsearch "layer" "4虚线层") nil)
(command "layer" "new" "4虚线层" "c" 6 "4虚线层" "lt" "DASHED" "4虚线层" ""))
(setq loop t pdlst nil pd nil )
(princ "\n请指定对象,[右键]退出:")
(while loop
(setq gr (grread t 15 2) code (car gr) pt (cadr gr))
(cond
((= code 3)
(if pd(setq pdlst nilpd nil)))
((or (= code 11) (= code 25))
(if pd (progn (princ "\n请指定对象,[右键]退出:") (entdel (car pdlst))
(setq pdlst nilpd nil )) (setq loop nil) ) )
((= code 5)
(if (setq nearpt (osnap pt "_NEA"))
(if (and (not pd) (setq ss (ssget "C" nearpt nearpt '((0 . "LINE"))))
(setq name (ssname ss 0)) (setq ent (entget name))
(not (member name pdlst)) )
(progn
(princ "\n[左键]确认,[右键]删除")
(setq pdlst (cons name pdlst) p1 (cdr (assoc 10 ent)) p2 (cdr (assoc 11 ent)))
(if (< (distance nearpt p2) (distance nearpt p1))
(setq p0 p2p2 p1p1 p0 ))
(setq p0 (polar p1 (angle p1 p2) (* 0.5 (distance p1 p2)))
ent (sub 10 p0 ent)ent (sub 11 p2 ent))(entmod ent)
(setq en (cdr ent) en (sub 10 p1 en) en (sub 11 p0 en))
(entmake (sub 8 "4虚线层" en))
(setq pd "Y" pdlst (cons (entlast) pdlst))))
(if pd (progn (princ "\n请指定对象,[右键]退出:") (entdel (car pdlst))
(setq ent (entget (last pdlst))ent (sub 10 p1 ent)
ent (sub 11 p2 ent))(entmod ent)
(setq pdlst nilpd nil) ))))))
(princ)
)
虽然少用，支持一下 楼主一直都是好牛逼， 这功能很实用 非常实用，谢谢 非常感谢langjs大师分享好程序 谢langjs大师分享 谢谢! langjs大师分享实用程序!!!!!!!
这个功能比较强大，方便了许多。