|
|
[code]
;;;========================================================================================;;;
(defun c:tt (/ 2elst a b c d1 delpts en endpts i lpts lss obj1 odlst pt1 pt2 ptiall ptilst ptm pts rpts ss tf)
(progn
(vl-load-com)
(defun yj-ss2lst (ss / i l)
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
;;;=====================================================
(defun IntersPointList (en1 lss / OBJ1 PTS)
(setq lss (vl-remove en1 lss))
(setq obj1 (vlax-ename->vla-object en1))
(setq pts
(vl-remove nil
(mapcar (function (lambda (x)
(vlax-invoke
obj1
'IntersectWith
(vlax-ename->vla-object x)
acExtendboth
)
)
)
lss
)
)
)
)
;|==============================================;;
;;;按序号删除表中的元素-------------------------yjtdkj.2021.07
参数: lst － 表
参数: n － 序号（从0开始）
参数: new － 新元素
返回: 新表
例子: (yj-LST-Idxremove '(11 22 33) 0 )
|;
(defun yj-LST-Idxremove (lst n / AA M NEWLST)
(setq newLst '())
(setq m 0)
(repeat (length lst)
(if (= m n)
(progn
(setq lst (cdr lst))
)
(progn
(setq aa (car lst))
(setq newLst (cons aa newLst))
(setq lst (cdr lst))
)
)
(setq m (1+ m))
)
(reverse newlst)
)
;;;取表中两两相等的点的表
(defun TwoEqual (ptlst / I NEWLST PT TMP)
(setq tmp ptlst)
(setq newlst '())
(while tmp
(setq pt (car tmp)
tmp (cdr tmp)
) ;end setq
(repeat (setq i (length tmp))
(if (equal (nth (setq i (1- i)) tmp) pt 1e-6)
(progn
(setq newlst (cons pt newlst))
(setq tmp (yj-LST-Idxremove tmp i))
)
)
)
)
newlst
)
;;;点表的差集
(defun ptlst-subtract (lst1 lst2 / I NEWLST PT TMP)
(while lst2
(setq pt (car lst2)
lst2 (cdr lst2)
) ;end setq
(repeat (setq i (length lst1))
(if (equal (nth (setq i (1- i)) lst1) pt 1e-6)
(setq lst1 (yj-LST-Idxremove lst1 i))
)
)
)
lst1
)
;;;点在点表中搜索，如果有，则返回找到的点及以后的表
(defun memberpts (p lst / PT TF)
(while (and lst (not tf))
(setq pt (car lst))
(if (equal p pt 1e-6)
(setq tf t)
(setq lst (cdr lst))
)
)
lst
)
;;;表变两元素表
(defun lstto2Elst (lst / E I NEWLST)
(setq newlst '())
(while lst
(setq e (car lst)
lst (cdr lst)
)
(if lst
(repeat (setq i (length lst))
(setq
newlst (cons (list e (nth (setq i (1- i)) lst)) newlst)
)
)
)
)
(reverse newlst)
)
;;;
(defun point2pline (lst ent / NEWENT)
(setq newent '((0 . "LWPOLYLINE")))
(foreach x '(100 67 410 62 6 370)
(if (assoc x ent)
(setq newent (cons (assoc x ent) newent))
) ;_ if
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(entmake
(append
(reverse newent)
(list '(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 1)
)
(apply 'append
(mapcar (function (lambda (x)
(list
(cons 10 (list (car x) (cadr x)))
(cons 40 0.0)
(cons 41 0.0)
(cons 42 0.0)
)
)
)
lst
)
)
(list (assoc 210 ent))
) ;_ append
)
(vla-endundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(entlast)
)
;;;----------------------------------------;;;
(setq *acad (vlax-get-acad-object)
*doc (vla-get-ActiveDocument *acad)
;;
*ms (if (= (getvar 'ctab) "Model")
(vla-get-modelSpace *doc)
(vla-get-paperSpace *doc)
)
)
(defun *error* (msg)
(mapcar 'setvar
'("cmdecho" "osmode" "peditaccept" "Pickstyle")
odlst
)
(vlax-invoke-method *doc 'EndUndoMark)
(if (not
(wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
)
(princ (strcat "\nError: " msg))
)
(princ)
)
(vlax-invoke-method *doc 'StartUndoMark)
(setq
odlst (mapcar 'getvar
'("cmdecho" "osmode" "peditaccept" "Pickstyle")
)
)
(mapcar 'setvar
'("cmdecho" "osmode" "peditaccept" "Pickstyle")
'(0 0 1 0)
)
)
;;;---------------------------------------------------------------------
;;;-------------------主程序开始----------------------------------------
;;;---------------------------------------------------------------------
(setq ss (ssget))
(if ss
(progn
(setq lss (yj-ss2lst ss))
(setq ptilst
(mapcar (function (lambda (x) (IntersPointList x lss))) lss)
)
(setq PtiAll (apply 'append ptilst))
(setq PtiAll (twoEqual PtiAll))
(setq delpts '())
(mapcar
(function (lambda (x)
(setq lpts '())
(setq rpts '())
(setq pts (ptlst-subtract PtiAll x))
(while pts
(setq ptm (car pts)
pts (cdr pts)
)
(setq pt1 (car x)
pt2 (cadr x)
)
(setq
a (- (cadr pt2) (cadr pt1))
b (- (car pt1) (car pt2))
c (- (* -1 a (car pt1)) (* b (cadr pt1)))
d1 (- (* -1 a (car ptm)) (* b (cadr ptm)))
)
(cond
((= d1 c)
nil
)
((> d1 c)
(setq lpts (cons ptm lpts))
)
((< d1 c)
(setq rpts (cons ptm rpts))
)
)
)
(if (< (length lpts) (length rpts))
(setq delpts (cons lpts delpts))
(setq delpts (cons rpts delpts))
)
)
)
ptilst
)
(setq delpts (apply 'append delpts))
(setq PtiAll (ptlst-subtract PtiAll delpts))
(setq 2elst (lstto2Elst PtiAll)) ;图元表转2元素图元表
(setq 2elst (vl-remove-if-not
(function (lambda (x)
(setq tf nil)
(repeat (setq i (length ptilst))
(setq pts (nth (setq i (1- i)) ptilst))
(if (and (memberpts (car x) pts)
(memberpts (cadr x) pts)
)
(setq tf t)
)
)
tf
)
)
2elst
)
) ;找到所有在线上两点
(if (= (length 2elst) (length lss))
(progn
(setq endpts (car 2elst))
(setq 2elst (cdr 2elst))
(while (/= (length endpts) (length lss))
(if (or (= i 0) (not i))
(setq i (length 2elst))
)
(setq pts (nth (setq i (1- i)) 2elst))
(cond ((equal (car endpts) (cadr pts) 1e-6)
(progn
(setq endpts (cons (car pts) endpts))
(setq 2elst (yj-LST-Idxremove 2elst i))
)
)
((equal (car endpts) (car pts) 1e-6)
(progn
(setq endpts (cons (cadr pts) endpts))
(setq 2elst (yj-LST-Idxremove 2elst i))
)
)
)
)
)
)
(setq en (point2pline endpts (entget (car lss))))
)
(progn
(mapcar 'setvar
'("cmdecho" "osmode" "peditaccept" "Pickstyle")
odlst
)
(exit)
)
)
(mapcar 'setvar
'("cmdecho" "osmode" "peditaccept" "Pickstyle")
odlst
)
(vlax-invoke-method *doc 'EndUndoMark)
(princ)
)[/code] |
|
发表于 2024-6-22 09:46:18
发表于 2024-8-6 10:42:43
