清理重复实体类集成（三领）

尘缘一生

• ;;图元合并删除、合并----【开始】------
• (defun c:duprem (/ ss)
•   (setq ss (ssget '((0 . "LINE,*POLYLINE,TEXT,MTEXT,CIRCLE,ARC,INSERT"))))
•   (ssduppe ss)
• )
• 
  
  • ;;(删除选择集中重叠的线、多段线、圆、圆弧、块、文字)----(一级)----
  • (defun ssduppe (ss / e name lis lw ly cl tp p1 p2 e_lst n slinearc spline scircle sinsert stxt)
  •   (setq e_lst (sysvar '("OSMODE" "CMDECHO")))  
  •   (setvar "OSMODE" 0)
  •   (setvar "CMDECHO" 0)
  •   (_undo1)
  •   (command "_.ucs" "")
  •   (setq slinearc (ssadd) spline (ssadd) scircle (ssadd) sinsert (ssadd) stxt (ssadd))
  •   (repeat (setq n (sslength ss))
  •     (setq name (ssname ss (setq n (1- n))) tp (dxf1 name 0) ly (dxf1 name 8) cl (ss-getcolor name) lw (linwind name))
  •     (cond
  •       ((or (= tp "LINE") (= tp "ARC"))
  •         (ssadd name slinearc)
  •       )
  •       ((and (= tp "LWPOLYLINE") (= lw 0) (= (dxf1 name 90) 2)) ;;0宽度两点多段线
  •         (setq p1 (vlax-curve-getstartpoint (en2obj name))
  •           p2 (vlax-curve-getendpoint (en2obj name))
  •         )
  •         (entdel name) (ssdel name ss)
  •         (fy_lineformat (makeline p1 p2) nil nil nil nil)
  •         (ssadd (entlast) slinearc) ;转直线集处理
  •       )
  •       ((and (= tp "LWPOLYLINE") (= lw 0) (> (dxf1 name 90) 2) ;;0宽度3点以上多段线
  •          (= (sl:pts-onLine (setq lis (order-pt (get-pl-pt name)))) t) ;共线
  •        )
  •         (entdel name) (ssdel name ss)
  •         (fy_lineformat (makeline (car lis) (last lis)) nil nil nil nil)
  •         (ssadd (entlast) slinearc);转直线集处理
  •       )
  •       ((and (= tp "LWPOLYLINE") (= lw 0) (> (dxf1 name 90) 2) ;;0宽度3点以上多段线
  •          (= (sl:pts-onLine (get-pl-pt name)) nil) ;不共线
  •        )
  •         (ssadd name spline) ;转多段线集处理
  •       )
  •       ((and (= tp "LWPOLYLINE") (> lw 0)) ;有宽度二维多段线
  •         (ssadd name spline) ;转多段线集处理
  •       )
  •       ((and (= tp "POLYLINE") (> lw 0));有宽度三维多段线
  •         (setq lis (get-pl-pt name))
  •         (if (= (dxf1 name 70) 8) ;不闭合
  •           (slch:lwpolyline lis nil lw ly cl nil)
  •           (slch:lwpolyline lis t lw ly cl nil)
  •         )
  •         (entdel name)
  •         (ssadd (entlast) spline) ;转多段线集处理
  •       )
  •       ((and (= tp "POLYLINE") (= lw 0));0宽度三维多段线
  •         (setq lis (get-pl-pt name))
  •         (entdel name) (ssdel name ss)
  •         (repeat (setq i (1- (length lis)))
  •           (fy_lineformat (makeline (nth i lis) (nth (1- i) lis)) nil nil nil nil)
  •           (ssadd (entlast) slinearc) ;转直线集处理
  •         )
  •       )
  •       ((= tp "CIRCLE")
  •         (ssadd name scircle)
  •       )
  •       ((= tp "INSERT")
  •         (ssadd name sinsert)
  •       )
  •       ((or (= tp "TEXT") (= tp "MTEXT"))
  •         (ssadd name stxt)
  •       )
  •     )
  •   )
  •   (if (> (sslength slinearc) 1) (vl-catch-all-apply 'undup (list slinearc))) ;直线 弧
  •   (if (> (sslength spline) 1) (vl-catch-all-apply 'unduppl (list spline))) ;多段线
  •   (if (> (sslength scircle) 1) (undup-cir scircle)) ;圆
  •   (if (> (sslength stxt) 1) (deladtxt stxt)) ;文字
  •   (if (> (sslength sinsert) 1) (congfukuai sinsert))  ;块
  •   (mapcar 'eval e_lst)
  •   (_undo2)
  • )
    
• ;;删除重复的线LINE 弧 CIR----(一级)-------
• ;;s:选择集
• (defun undup (s / ang k a a1 a2 sty sline sarc n enam tp e_lst)
•   (defun t-ang (ang k)
•     (rem (+ 2pi ang) k)
•   )
•   ;;判断a是否在 a1至a2两点连线上----
•   (defun on_ent (a a1 a2 sty)
•     (if (= sty "line")
•       (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
•       (if (> a2 a1) (>= a2 a a1) (or (<= a a2) (>= a a1)))
•     )
•   )
•   ;;s:选择集 sty:实体类型字符串"line""arc"
•   (defun slundup (s sty / nm m n ss nam enam1 enam2 spt1 ept1 cpt1 r1 r2 spt2 ept2 cpt2 ptlis d1 d2 d3 d4)
•     (setq nm 0)
•     (if (= sty "line") ;;删除长度小于 0.01的直线
•       (repeat (setq n (sslength s))
•         (setq enam1 (ssname s (setq n (1- n))))
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (if (<= (distance spt1 ept1) 0.01)
•           (progn (ssdel enam1 s) (entdel enam1) (setq nm (1+ nm)))
•         )
•       )
•     )
•     (repeat (setq n (sslength s)) ;合并重复线、弧
•       (setq enam1 (ssname s (setq n (1- n))))
•       (if (= sty "line")
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (setq spt1 (t-ang (dxf1 enam1 50) 2pi)
•           ept1 (t-ang (dxf1 enam1 51) 2pi)
•           cpt1 (dxf1 enam1 10)
•           r1 (dxf1 enam1 40)
•         )
•       )
•       (if
•         (setq ss
•           (if (= sty "line")
•             (ssget
•               "CP"
•               (list
•                 (polar spt1 (angle ept1 spt1) (* SLBL 0.2))
•                 (polar ept1 (- (angle spt1 ept1) pi4) (* SLBL 0.25))
•                 (polar ept1 (+ (angle spt1 ept1) pi4) (* SLBL 0.25))
•               )
•               '((0 . "LINE"))
•             )
•             (ssget "X" (list (cons 0 "ARC") (cons 10 cpt1) (cons 40 r1)))
•           )
•         )
•         (progn
•           (ssdel enam1 ss) ;;次选择集先删除主线
•           (repeat (setq m (sslength ss))
•             (setq nam (ssname ss (setq m (1- m))))
•             (if (not (ssmemb nam s)) (ssdel nam ss)) ;;如果主选择集都没有，选择集不交差，删除次选择集实体
•           ) ;以上确保 主集S 次集 SS 正确
•           (repeat (setq m (sslength ss))
•             (setq enam2 (ssname ss (setq m (1- m))))
•             (if (= sty "line")
•               (setq spt2 (dxf1 enam2 10) ept2 (dxf1 enam2 11))
•               (setq spt2 (t-ang (dxf1 enam2 50) 2pi)
•                 ept2 (t-ang (dxf1 enam2 51) 2pi)
•                 cpt2 (dxf1 enam2 10)
•                 r2 (dxf1 enam2 40)
•               )
•             )
•             (cond
•               ((and (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty))  ;;次线落在主线上
•                 (entdel enam2)   ;;删除次线
•               )
•               ((and (on_ent spt1 spt2 ept2 sty) (on_ent ept1 spt2 ept2 sty)) ;;主线落在次线上
•                 (entdel enam1)   ;;删除主线
•                 (setq enam1 enam2 spt1 spt2 ept1 ept2)  ;;次线转为主线
•                 (if (= sty "arc")
•                   (setq cpt1 cpt2 r1 r2)
•                 )
•               )
•               ((and
•                  (if (= sty "line") (equal (angle spt1 ept1) (angle spt2 ept2) 0.001)) ;;平行
•                  (or (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty)) ;;且一点在线上
•                )
•                 (entdel enam2) ;删除次线
•                 (if (= sty "line")
•                   (progn
•                     (if (on_ent spt2 spt1 ept1 sty)
•                       (setq spt2 ept2)
•                     )
•                     (if (> (distance spt1 spt2) (distance ept1 spt2))
•                       (progn (sl_subupd enam1 11 spt2) (setq ept1 spt2))
•                       (progn (sl_subupd enam1 10 spt2) (setq spt1 spt2))
•                     )
•                   )
•                   (if (on_ent spt2 spt1 ept1 sty)
•                     (progn (sl_subupd enam1 51 ept2) (setq ept1 ept2))
•                     (progn (sl_subupd enam1 50 spt2) (setq spt1 spt2))
•                   )
•                 )
•               )
•               ((and
•                  (= sty "line")
•                  (= (sl:pts-onLine (list spt1 ept1 spt2 ept2)) t) ;共线判断
•                )
•                 (setq d1 (distance spt1 spt2))
•                 (setq d2 (distance spt1 ept2))
•                 (setq d3 (distance ept1 spt2))
•                 (setq d4 (distance ept1 ept2))
•                 (if (and (< (min d1 d2 d3 d4) (* SLBL 0.1)))
•                   (progn
•                     (setq ptlis (order-pt (list spt1 ept1 spt2 ept2)))
•                     (entdel enam2) ;;删除次线
•                     (sl_subupd enam1 10 (car ptlis))
•                     (setq spt1 (car ptlis)) ;下次扩展延伸选择用
•                     (sl_subupd enam1 11 (last ptlis))
•                     (setq ept1 (last ptlis)) ;下次扩展延伸选择用
•                   )
•                 )
•               )
•               (T (setq nm (1- nm)))
•             )
•             (setq nm (1+ nm))
•           );end repeat
•         )
•       )
•     )
•     (prompt
•       (strcat
•         (slmsg " 选到" " 選到" " Select")
•         (itoa (sslength s))
•         (slmsg "个" "個" "num")
•         sty
•         (slmsg "消去" "消去" "delete")
•         (itoa nm)
•         (slmsg "个" "個" "num")
•       )
•     )
•   )
•   ;;主程序开始-------------
•   (setq e_lst (sysvar '("osmode" "cmdecho")))
•   (setvar "cmdecho" 0)
•   (setvar "OSMODE" 0)
•   (setq sline (ssadd) sarc (ssadd))
•   (repeat (setq n (sslength s))
•     (setq enam (ssname s (setq n (1- n))))
•     (setq tp (dxf1 enam 0))
•     (cond
•       ((= tp "LINE")
•         (ssadd enam sline)
•       )
•       ((= tp "ARC")
•         (ssadd enam sarc)
•       )
•     )
•   )
•   (if (> (sslength sline) 1) (slundup sline "line"))
•   (if (> (sslength sarc) 1) (slundup sarc "arc"))
•   (mapcar 'eval e_lst)
•   (princ)
• )
• ;;删除重复的多段线、重合点、共线点------(一级)--------
• (defun unduppl (ss / num i j lst lstx lsty lstx1 lsty1 ress tp nam e)
•   ;;删除完全重合----------
•   (setq i 0 num (sslength ss) ress (ssadd))  ;初始化变量,设置i为1的原因是方便j取值
•   (repeat (1- num)  ;外循环开始,循环次数为多段线个数减1
•     (setq lst (get-pl-pt (ssname ss i)))
•     (setq lstx (mapcar 'car (vl-sort lst '(lambda (a b) (< (car a) (car b))))))  ;按照X坐标从小到大排序并提取X坐标组成表
•     (setq lsty (mapcar 'cadr (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b))))))  ;按照Y坐标从小到大排序并提取Y坐标组成表
•     (setq i (1+ i))
•     (setq j i)     ;j的值为i
•     (repeat (- num i)  ;内循坏开始,循坏次数为多段线个数减去i
•       (setq nam (ssname ss j))
•       (setq lst1 (get-pl-pt nam))
•       (setq lstx1 (mapcar 'car (vl-sort lst1 '(lambda (a b) (< (car a) (car b))))))
•       (setq lsty1 (mapcar 'cadr (vl-sort lst1 '(lambda (a b) (< (cadr a) (cadr b))))))
•       (if (and (equal lstx lstx1 1e-5) (equal lsty lsty1 1e-5)) ;对比两个X和两个Y的表看是否一致,一致就删除
•         (ssadd nam ress)
•       )
•       (setq j (1+ j))
•     )
•   )
•   (if ress
•     (progn
•       (setq ss (ssdiff ss ress)) ;;差集
•       (if (> (sslength ress) 0) (sl:-erase ress))
•       (prompt
•         (strcat
•           (slmsg "||选到" "||選到" "||Select")
•           (itoa num)
•           (slmsg "条多段线,消去完全重合->" "條多段線,消去完全重合->" "num Polylines,Erase Full Coincidence->")
•           (itoa (sslength ress))
•           (slmsg "个" "個" "num")
•         )
•       )
•     )
•   )
•   (setq e (entlast))
•   (slexpline ss);;->出口，线型实体3点以上者，炸开单线集成，宽度不变
•   (setq ss (last_ent e))
•   ;;删除重合点、共线点-------
•   (repeat (setq i (sslength ss))
•     (setq nam (ssname ss (setq i (1- i))) tp (dxf1 nam 0))
•     (cond
•       ((= tp "LWPOLYLINE");;->出口，删除二维多段线重合点，共线点
•         (x@-delvx nam nil nil)
•       )
•       ((= tp "POLYLINE")  ;;->出口，删除三维多段线重复点
•         (dump2dPoly nam)
•       )
•     )
•   )
• )
• ;;删除重块--------(一级)-------
• (defun congfukuai (ss / i pt10 sspt10 nam ssnam n ss1 ss88 ssn ssn1 u)
•   (setq u 0 ss88 (ssadd))
•   (repeat (sslength ss)
•     (setq ssn (ssname ss u))
•     (ssadd ssn ss88)
•     (setq u (1+ u))
•   )
•   (setq n 0 ss1 (ssadd))
•   (repeat (sslength ss)
•     (setq ssn (ssname ss n))
•     (setq pt10 (dxf1 ssn 10))
•     (setq nam (dxf1 ssn 2))
•     (setq i 0)
•     (ssdel ssn ss88)
•     (repeat (sslength ss88)
•       (setq ssn1 (ssname ss88 i))
•       (setq sspt10 (dxf1 ssn1 10))
•       (setq ssnam (dxf1 ssn1 2))
•       (if (and (< (distance pt10 sspt10) (* slbl 0.5)) (wcmatch nam ssnam))
•         (ssadd ssn1 ss1)
•       )
•       (setq i (1+ i))
•     )
•     (setq n (1+ n))
•   )
•   (setq n (sslength ss1))
•   (sl:-erase ss1)
•   (prompt
•     (strcat
•       (slmsg "||选到" "||選到" "||Select")
•       (itoa (sslength ss))
•       (slmsg "个图块,消去->" "個圖塊,消去->" "num blk,delete->")
•       (rtos n 2 0)
•       (slmsg "个重块!" "個重塊!" "num overlap blk!")
•     )
•   )
• )
• ;;删除重叠文字------(一级)-------
• (defun deladtxt (ss / enam u ss88 n ss1 en_data dxfl dxf10 dxf101 dxf11 dxf40 dxf401 i)
•   (setq u 0 ss88 (ssadd))
•   (repeat (sslength ss)
•     (setq enam (ssname ss u))
•     (ssadd enam ss88)
•     (setq u (1+ u))
•   )
•   (setq n 0 ss1 (ssadd))
•   (repeat (sslength ss)
•     (setq enam (ssname ss n))
•     (setq en_data (entget enam))
•     (setq dxf10 (dxf1 en_data 10) dxf40 (dxf1 en_data 40) dxfl (dxf1 en_data 1))
•     (ssdel enam ss88)
•     (setq i 0)
•     (repeat (sslength ss88)
•       (setq en1 (ssname ss88 i))
•       (setq en_data (entget en1))
•       (setq dxf101 (dxf1 en_data 10) dxf401 (dxf1 en_data 40) dxf11 (dxf1 en_data 1))
•       (if (and (equal dxf10 dxf101) (equal dxf40 dxf401) (= dxfl dxf11))
•         (ssadd en1 ss1)
•       )
•       (setq i (1+ i))
•     )
•     (setq n (1+ n))
•   )
•   (setq n (sslength ss1))
•   (sl:-erase ss1)
•   (prompt
•     (strcat
•       (slmsg "||选到" "||選到" "||Select")
•       (itoa (sslength ss))
•       (slmsg "个文字,消去->" "個文字,消去->" "num txt,delete->")
•       (rtos n 2 0)
•       (slmsg "个重叠文字!" "個重疊文字!" "num overlap txt!")
•     )
•   )
•   (princ)
• )
• ;删除相同直径的圆(全图)-----(一级)------
• ;;s:circle 选择集
• (defun undup-cir (s / nm m n ss nam enam1 cpt1 r1 kk)
•   (setq nm 0 kk (itoa (sslength s)))
•   (repeat (setq n (sslength s))
•     (setq enam1 (ssname s (setq n (1- n))))
•     (setq cpt1 (dxf1 enam1 10) r1 (dxf1 enam1 40))
•     (if (setq ss (ssget "x" (list (cons 0 "circle") (cons 10 cpt1) (cons 40 r1))))
•       (progn
•         (ssdel enam1 ss)
•         (repeat (setq m (sslength ss))
•           (setq nam (ssname ss (setq m (1- m))))
•           (if (not (ssmemb nam s)) (ssdel nam ss))
•         )
•         (sl:-erase ss)
•         (setq nm (+ nm (sslength ss)))
•       )
•     )
•   )
•   (prompt
•     (strcat
•       (slmsg "\n 选到" "\n 選到" "\n Select")
•       kk
•       (slmsg "个圆" "個圓" "num circle")
•       (slmsg "消去->" "消去->" "delete->")
•       (itoa nm)
•       (slmsg "个" "個" "num")
•     )
•   )
• ) ;;图元合并(删除图纸中重叠的线、圆、圆弧、块、文字)---【结束】-----
  

zhaoquan888

刚好用上，多谢大师分享

尘缘一生

更新这部分，加次线选择集的判断，防止次线为空时崩溃

• ;;删除重复的线LINE 弧 CIR----(一级)-------
• ;;s:选择集
• (defun undup (s / ang k a a1 a2 sty sline sarc n enam tp e_lst)
•   (defun t-ang (ang k)
•     (rem (+ 2pi ang) k)
•   )
•   ;;判断a是否在 a1至a2两点连线上----
•   (defun on_ent (a a1 a2 sty)
•     (if (= sty "line")
•       (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
•       (if (> a2 a1) (>= a2 a a1) (or (<= a a2) (>= a a1)))
•     )
•   )
•   ;;s:选择集 sty:实体类型字符串"line""arc"
•   (defun slundup (s sty / nm m n ss nam enam1 enam2 spt1 ept1 cpt1 r1 r2 spt2 ept2 cpt2 ptlis d1 d2 d3 d4)
•     (setq nm 0)
•     (if (= sty "line") ;;删除长度小于 0.01的直线
•       (repeat (setq n (sslength s))
•         (setq enam1 (ssname s (setq n (1- n))))
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (if (<= (distance spt1 ept1) 0.01)
•           (progn (ssdel enam1 s) (entdel enam1) (setq nm (1+ nm)))
•         )
•       )
•     )
•     (repeat (setq n (sslength s)) ;合并重复线、弧
•       (setq enam1 (ssname s (setq n (1- n))))
•       (if (= sty "line")
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (setq spt1 (t-ang (dxf1 enam1 50) 2pi)
•           ept1 (t-ang (dxf1 enam1 51) 2pi)
•           cpt1 (dxf1 enam1 10)
•           r1 (dxf1 enam1 40)
•         )
•       )
•       (if
•         (setq ss
•           (if (= sty "line")
•             (ssget
•               "CP"
•               (list
•                 (polar spt1 (angle ept1 spt1) (* SLBL 0.2))
•                 (polar ept1 (- (angle spt1 ept1) pi4) (* SLBL 0.25))
•                 (polar ept1 (+ (angle spt1 ept1) pi4) (* SLBL 0.25))
•               )
•               '((0 . "LINE"))
•             )
•             (ssget "X" (list (cons 0 "ARC") (cons 10 cpt1) (cons 40 r1)))
•           )
•         )
•         (progn
•           (ssdel enam1 ss) ;;次选择集先删除主线
•           (if (> (sslength ss) 0) ;确保ss存在实体
•             (progn
•               (repeat (setq m (sslength ss))
•                 (setq nam (ssname ss (setq m (1- m))))
•                 (if (not (ssmemb nam s)) (ssdel nam ss)) ;;如果主选择集都没有，选择集不交差，删除次选择集实体
•               ) ;以上确保 主集S 次集 SS 正确
•               (if (> (sslength ss) 0) ;确保ss存在实体
•                 (repeat (setq m (sslength ss))
•                   (setq enam2 (ssname ss (setq m (1- m))))
•                   (if (= sty "line")
•                     (setq spt2 (dxf1 enam2 10) ept2 (dxf1 enam2 11))
•                     (setq spt2 (t-ang (dxf1 enam2 50) 2pi)
•                       ept2 (t-ang (dxf1 enam2 51) 2pi)
•                       cpt2 (dxf1 enam2 10)
•                       r2 (dxf1 enam2 40)
•                     )
•                   )
•                   (cond
•                     ((and (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty))  ;;次线落在主线上
•                       (ssdel enam2 ss) (entdel enam2)   ;;删除次线
•                     )
•                     ((and (on_ent spt1 spt2 ept2 sty) (on_ent ept1 spt2 ept2 sty)) ;;主线落在次线上
•                       (entdel enam1)   ;;删除主线
•                       (setq enam1 enam2 spt1 spt2 ept1 ept2)  ;;次线转为主线
•                       (if (= sty "arc")
•                         (setq cpt1 cpt2 r1 r2)
•                       )
•                     )
•                     ((and
•                        (if (= sty "line") (equal (angle spt1 ept1) (angle spt2 ept2) 0.001)) ;;平行
•                        (or (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty)) ;;且一点在线上
•                      )
•                       (ssdel enam2 ss) (entdel enam2)   ;;删除次线
•                       (if (= sty "line")
•                         (progn
•                           (if (on_ent spt2 spt1 ept1 sty)
•                             (setq spt2 ept2)
•                           )
•                           (if (> (distance spt1 spt2) (distance ept1 spt2))
•                             (progn (sl_subupd enam1 11 spt2) (setq ept1 spt2))
•                             (progn (sl_subupd enam1 10 spt2) (setq spt1 spt2))
•                           )
•                         )
•                         (if (on_ent spt2 spt1 ept1 sty)
•                           (progn (sl_subupd enam1 51 ept2) (setq ept1 ept2))
•                           (progn (sl_subupd enam1 50 spt2) (setq spt1 spt2))
•                         )
•                       )
•                     )
•                     ((and
•                        (= sty "line")
•                        (= (sl:pts-onLine (list spt1 ept1 spt2 ept2)) t) ;共线
•                      )
•                       (setq d1 (distance spt1 spt2))
•                       (setq d2 (distance spt1 ept2))
•                       (setq d3 (distance ept1 spt2))
•                       (setq d4 (distance ept1 ept2))
•                       (if (and (< (min d1 d2 d3 d4) (* SLBL 0.1)))
•                         (progn
•                           (setq ptlis (order-pt (list spt1 ept1 spt2 ept2)))
•                           (ssdel enam2 ss) (entdel enam2)   ;;删除次线
•                           (sl_subupd enam1 10 (car ptlis))
•                           (setq spt1 (car ptlis)) ;下次扩展延伸选择用
•                           (sl_subupd enam1 11 (last ptlis))
•                           (setq ept1 (last ptlis)) ;下次扩展延伸选择用
•                         )
•                       )
•                     )
•                     (T (setq nm (1- nm)))
•                   )
•                   (setq nm (1+ nm))
•                 );end repeat
•               );if
•             )
•           )
•         )
•       )
•     )
•     (prompt
•       (strcat
•         (slmsg " 选到" " 選到" " Select")
•         (itoa (sslength s))
•         (slmsg "个" "個" "num")
•         sty
•         (slmsg "消去" "消去" "delete")
•         (itoa nm)
•         (slmsg "个" "個" "num")
•       )
•     )
•   )
•   ;;主程序开始-------------
•   (setq e_lst (sysvar '("osmode" "cmdecho")))
•   (setvar "cmdecho" 0)
•   (setvar "OSMODE" 0)
•   (command "_.ucs" "")
•   (setq sline (ssadd) sarc (ssadd))
•   (repeat (setq n (sslength s))
•     (setq enam (ssname s (setq n (1- n))))
•     (setq tp (dxf1 enam 0))
•     (cond
•       ((= tp "LINE")
•         (ssadd enam sline)
•       )
•       ((= tp "ARC")
•         (ssadd enam sarc)
•       )
•     )
•   )
•   (if (> (sslength sline) 1) (slundup sline "line"))
•   (if (> (sslength sarc) 1) (slundup sarc "arc"))
•   (mapcar 'eval e_lst)
•   (princ)
• )
  

baby绑定命运线

支持一下.....

尘缘一生

再次改写

• ;;删除重复的线LINE 弧 CIR----(一级)-------
• ;;s:选择集
• (defun undup (s / ang k a a1 a2 sty sline sarc n enam tp e_lst)
•   (defun t-ang (ang k)
•     (rem (+ 2pi ang) k)
•   )
•   ;;判断a是否在 a1至a2两点连线上
•   (defun on_ent (a a1 a2 sty)
•     (if (= sty "line")
•       (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
•       (if (> a2 a1) (>= a2 a a1) (or (<= a a2) (>= a a1)))
•     )
•   )
•   ;;s:选择集 sty:实体类型字符串"line""arc"
•   (defun slundup (s sty / nm len0 m n ss nam enam1 enam2 spt1 ept1 cpt1 r1 r2 spt2 ept2 cpt2 ptlis d1 d2 d3 d4)
•     (setq nm 0 len0 (sslength s))
•     (if (= sty "line") ;;删除长度小于 0.01的直线
•       (repeat (setq n (sslength s))
•         (setq enam1 (ssname s (setq n (1- n))))
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (if (<= (distance spt1 ept1) 0.01)
•           (progn (ssdel enam1 s) (entdel enam1) (setq nm (1+ nm)))
•         )
•       )
•     )
•     (repeat (setq n (sslength s)) ;合并重复线、弧
•       (setq enam1 (ssname s (setq n (1- n))))
•       (if (= sty "line")
•         (setq spt1 (dxf1 enam1 10) ept1 (dxf1 enam1 11))
•         (setq
•           spt1 (t-ang (dxf1 enam1 50) 2pi)
•           ept1 (t-ang (dxf1 enam1 51) 2pi)
•           cpt1 (dxf1 enam1 10)
•           r1 (dxf1 enam1 40)
•         )
•       )
•       (if
•         (setq ss
•           (if (= sty "line")
•             (ssget
•               "CP"
•               (list
•                 (polar spt1 (angle ept1 spt1) (* SLBL 2))
•                 (polar ept1 (- (angle spt1 ept1) pi4) (* SLBL 2.5))
•                 (polar ept1 (+ (angle spt1 ept1) pi4) (* SLBL 2.5))
•               )
•               '((0 . "LINE"))
•             )
•             (ssget "X" (list (cons 0 "ARC") (cons 10 cpt1) (cons 40 r1)))
•           )
•         )
•         (progn
•           (ssdel enam1 ss) ;;次选择集先删除主线
•           (if (> (sslength ss) 0) ;确保ss存在实体
•             (progn
•               (repeat (setq m (sslength ss))
•                 (setq nam (ssname ss (setq m (1- m))))
•                 (if (not (ssmemb nam s)) (ssdel nam ss)) ;;如果主选择集都没有，选择集不交差，删除次选择集实体
•               ) ;以上确保 主集S 次集 SS 正确
•               (if (> (sslength ss) 0) ;确保ss存在实体
•                 (repeat (setq m (sslength ss))
•                   (setq enam2 (ssname ss (setq m (1- m))))
•                   (if (= sty "line")
•                     (setq spt2 (dxf1 enam2 10) ept2 (dxf1 enam2 11))
•                     (setq spt2 (t-ang (dxf1 enam2 50) 2pi)
•                       ept2 (t-ang (dxf1 enam2 51) 2pi)
•                       cpt2 (dxf1 enam2 10)
•                       r2 (dxf1 enam2 40)
•                     )
•                   )
•                   (cond
•                     ((and (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty))  ;;次线落在主线上
•                       (setq ptlis (order-pt (list spt1 ept1 spt2 ept2)))
•                       (ssdel enam2 ss) (entdel enam2)   ;;删除次线
•                       (if (ssmemb enam2 s) ;如果次线也是主线选择集之一
•                         (progn
•                           (ssdel enam2 s)
•                           (setq nm (1+ nm))
•                         )
•                       )
•                       (sl_subupd enam1 10 (car ptlis))
•                       (setq spt1 (car ptlis)) ;下次扩展延伸选择用
•                       (sl_subupd enam1 11 (last ptlis))
•                       (setq ept1 (last ptlis)) ;下次扩展延伸选择用
•                     )
•                     ((and (on_ent spt1 spt2 ept2 sty) (on_ent ept1 spt2 ept2 sty)) ;;主线落在次线上
•                       (setq ptlis (order-pt (list spt1 ept1 spt2 ept2)))
•                       (ssdel enam2 ss)
•                       (if (ssmemb enam2 s) ;如果次线也是主线选择集之一
•                         (progn
•                           (ssdel enam2 s)
•                           (setq nm (1+ nm))
•                         )
•                       )
•                       (entdel enam2)   ;;删除次线
•                       (sl_subupd enam1 10 (car ptlis))
•                       (setq spt1 (car ptlis)) ;下次扩展延伸选择用
•                       (sl_subupd enam1 11 (last ptlis))
•                       (setq ept1 (last ptlis)) ;下次扩展延伸选择用
•                       (if (= sty "arc")
•                         (setq cpt1 cpt2 r1 r2)
•                       )
•                     )
•                     ((and
•                        (if (= sty "line") (equal (angle spt1 ept1) (angle spt2 ept2) 0.001)) ;;平行
•                        (or (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty)) ;;且一点在线上
•                      )
•                       (ssdel enam2 ss)
•                       (if (ssmemb enam2 s) ;如果次线也是主线选择集之一
•                         (progn
•                           (ssdel enam2 s)
•                           (setq nm (1+ nm))
•                         )
•                       )
•                       (entdel enam2)   ;;删除次线
•                       (if (= sty "line")
•                         (progn
•                           (if (on_ent spt2 spt1 ept1 sty)
•                             (setq spt2 ept2)
•                           )
•                           (if (> (distance spt1 spt2) (distance ept1 spt2))
•                             (progn (sl_subupd enam1 11 spt2) (setq ept1 spt2))
•                             (progn (sl_subupd enam1 10 spt2) (setq spt1 spt2))
•                           )
•                         )
•                         (if (on_ent spt2 spt1 ept1 sty)
•                           (progn (sl_subupd enam1 51 ept2) (setq ept1 ept2))
•                           (progn (sl_subupd enam1 50 spt2) (setq spt1 spt2))
•                         )
•                       )
•                     )
•                     ((and
•                        (= sty "line")
•                        (= (sl:pts-onLine (list spt1 ept1 spt2 ept2)) t) ;共线
•                        (= (on_ent spt2 spt1 ept1 sty) nil) ;次线短点1不在主线
•                        (= (on_ent ept2 spt1 ept1 sty) nil) ;次线短点2也不在主线
•                      )
•                       (setq d1 (distance spt1 spt2))
•                       (setq d2 (distance spt1 ept2))
•                       (setq d3 (distance ept1 spt2))
•                       (setq d4 (distance ept1 ept2))
•                       (if (and (< (min d1 d2 d3 d4) (* SLBL 0.1)))
•                         (progn
•                           (setq ptlis (order-pt (list spt1 ept1 spt2 ept2)))
•                           (ssdel enam2 ss)
•                           (if (ssmemb enam2 s) ;如果次线也是主线选择集之一
•                             (progn
•                               (ssdel enam2 s)
•                               (setq nm (1+ nm))
•                             )
•                           )
•                           (entdel enam2)   ;;删除次线
•                           (sl_subupd enam1 10 (car ptlis))
•                           (setq spt1 (car ptlis)) ;下次扩展延伸选择用
•                           (sl_subupd enam1 11 (last ptlis))
•                           (setq ept1 (last ptlis)) ;下次扩展延伸选择用
•                         )
•                       )
•                     )
•                   )
•                 );end repeat
•               );if
•             )
•           )
•         )
•       )
•     )
•     (prompt
•       (strcat
•         (slmsg " 处理" " 處理" " Delete Merge")
•         (itoa len0)
•         (slmsg "个" "個" "num")
•         sty
•         (slmsg "消去" "消去" "delete")
•         (itoa nm)
•         (slmsg "个" "個" "num")
•       )
•     )
•   )
•   ;;主程序开始-------------
•   (vl-load-com)
•   (setq e_lst (sysvar '("osmode" "cmdecho")))
•   (setvar "cmdecho" 0)
•   (setvar "OSMODE" 0)
•   (command "_.ucs" "")
•   (setq sline (ssadd) sarc (ssadd))
•   (repeat (setq n (sslength s))
•     (setq enam (ssname s (setq n (1- n))))
•     (setq tp (dxf1 enam 0))
•     (cond
•       ((= tp "LINE")
•         (ssadd enam sline)
•       )
•       ((= tp "ARC")
•         (ssadd enam sarc)
•       )
•     )
•   )
•   (if (> (sslength sline) 1) (slundup sline "line"))
•   (if (> (sslength sarc) 1) (slundup sarc "arc"))
•   (mapcar 'eval e_lst)
•   (princ)
• )
  

tm010111

向大师学习 厉害

andyzha

测试了一下，好像有函数有问题，提示no function definition: SYSVAR！

muwind

andyzha 发表于 2022-12-3 17:15
测试了一下，好像有函数有问题，提示no function definition: SYSVAR！

我没详细看，代码太多了，这个函数就是设置变量的 删除相关项目 或者自己用setvar 一个一个设置应该就可以了

zhangcan0515

少一堆自定义函数