lisp实现框选裁切_《剪切成虚线》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

;;; ================================

;;; ================================

;;;    《剪切成虚线》v3.0(支持框选)

;;; 功能：将直线、圆、圆弧剪切成虚线

;;; 使用：选择到目标左键确认右键删除

;;;       a,s键调整虚线线型比例

;;;       未选择到目标时右键退出程序

;;;  by:langjs            2020.3.18

;;; ================================

(defun c:jq (/ #erryx001 $orr a b bh code e e1 e2 elst1 elst2 elst3 elst4 en en1 ent f gr i j jiao1 jiao2 len len_lst loop lst lstlst

lstlst1 mypt name name2 name3 name4 name5 namelst nearpt nenalst newdata nilpd obj obj1 obj2 p0 pd pdlst pend pls pn

psta pt pt2 ptl ptlst pts r r1 r2 snap ss ss1 ss2 vc vh vs x xuname zw

)

(defun hh:remove (en / newdata)      ; 去除多段线重点

(foreach e (entget en)

(if (and

(member e newdata)

(= 10 (car e))

)

nil

(setq newdata (cons e newdata))

)

)

(entmod (reverse newdata))

)

(defun hh:twoentsinters (e1 e2 / obj1 obj2 ptl pts) ; 两对象交点列表

(setq obj1 (vlax-ename->vla-object e1)

obj2 (vlax-ename->vla-object e2)

pts (vlax-invoke obj1 'intersectwith obj2 0)

)

(while pts

(setq ptl (cons (list (car pts) (cadr pts)) ptl)

pts (cdddr pts)

)

)

ptl

)

(defun pypx (pt lst name / i mypt obj x) ; 返回点在对象上相邻点

(setq obj (vlax-ename->vla-object name))

(if (= (cdr (assoc 0 (entget name))) "CIRCLE")

(progn

(if (or

(<= (vlax-curve-getdistatpoint obj pt) (vlax-curve-getdistatpoint obj (car lst)))

(>= (vlax-curve-getdistatpoint obj pt) (vlax-curve-getdistatpoint obj (last lst)))

)

(progn

(setq mypt (list (last lst) (car lst)))

)

(progn

(setq i 0)

(foreach x lst

(if (>= (vlax-curve-getdistatpoint obj pt) (vlax-curve-getdistatpoint obj x))

(setq i (1+ i))

)

)

(if (nth i lst)

(setq mypt (list (nth (1- i) lst) (nth i lst)))

(setq mypt (list (nth (- i 2) lst) (nth (1- i) lst)))

)

)

)

)

(progn

(setq i 0)

(foreach x lst

(if (>= (vlax-curve-getdistatpoint obj pt) (vlax-curve-getdistatpoint obj x))

(setq i (1+ i))

)

)

(if (nth i lst)

(if (/= i 0)

(setq mypt (list (nth (1- i) lst) (nth i lst)))

(setq mypt (list (car lst) (cadr lst)))

)

(setq mypt (list (nth (- i 2) lst) (nth (1- i) lst)))

)

)

)

mypt

)

(defun #erryx001 (s)

(if (= pd "Y")

(progn

(foreach x nenalst

(entdel x)

)

(entdel (last pdlst))

(setq nenalst nil

ptlst nil

pdlst nil

pd "N"

)

)

)

(setvar "osmode" snap)               ; 恢复捕捉

(command ".UNDO" "E")

(setq *error* $orr)

)

(defun sub (i x ent)                       ; 更新列表

(subst

(cons i x)

(assoc i ent)

ent

)

)

(defun assname (name i)               ; 取得列表

(setq ent (entget name))

(cdr (assoc i ent))

)

(defun huatu (pt pd /)

(if (setq nearpt (osnap pt "_NEA"))

(if (and

(setq ss (ssget "C" nearpt nearpt '((0 . "LINE,CIRCLE,ARC,LWPOLYLINE"))))

(/