【e派】工具箱函数再揭秘及应用实例

xyp1964 · 发表于 2012-7-30 13:52

本帖最后由 xyp1964 于 2019-1-26 17:05 编辑

;; xyp-Ssdel 选择集中删除特定类实体 (xyp-Ssdel sss "1")
;|
实例：
删除特定图层实体：
(setq ss (xyp-Ssdel (ssget) 8 "1"))
(setq ss (xyp-Ssdel (ssget) 8 '("1" "2")))
删除特定实体：
(setq ss (xyp-Ssdel (ssget) 0 "circle"))
(setq ss (xyp-Ssdel (ssget) 0 '("Line" "arc")))
删除特定文本：
(setq ss (xyp-Ssdel (ssget) 1 "test"))
(setq ss (xyp-Ssdel (ssget) 1 '("test" "测试")))
|;
(defun xyp-Ssdel (sss code lst / ss i s1)
(if (= (type sss) 'PICKSET)
(progn
(cond ((= (type lst) 'STR)
(setq ss (ssadd)
i -1
)
(while (setq s1 (ssname sss (setq i (1+ i))))
(if (/= (strcase (cdr (assoc code (entget s1)))) (strcase lst))
(setq ss (ssadd s1 ss))
)
)
)
((= (type lst) 'LIST)
(foreach x lst
(setq ss (xyp-Ssdel sss x)
sss ss
)
)
)
)
ss
)
)
)

;; xyp-Ssdel 选择集中删除特定类实体 (xyp-Ssdel sss "1") 
;| 
实例： 
删除特定图层实体： 
(setq ss (xyp-Ssdel (ssget) 8 "1")) 
(setq ss (xyp-Ssdel (ssget) 8 '("1" "2"))) 
删除特定实体： 
(setq ss (xyp-Ssdel (ssget) 0 "circle")) 
(setq ss (xyp-Ssdel (ssget) 0 '("Line" "arc"))) 
删除特定文本： 
(setq ss (xyp-Ssdel (ssget) 1 "test")) 
(setq ss (xyp-Ssdel (ssget) 1 '("test" "测试"))) 
|; 
(defun xyp-Ssdel (sss code lst / ss i s1) 
  (if (= (type sss) 'PICKSET) 
    (progn 
      (cond ((= (type lst) 'STR) 
             (setq ss (ssadd) 
                   i  -1 
             ) 
             (while (setq s1 (ssname sss (setq i (1+ i)))) 
               (if (/= (strcase (cdr (assoc code (entget s1)))) (strcase lst)) 
                 (setq ss (ssadd s1 ss)) 
               ) 
             ) 
            ) 
            ((= (type lst) 'LIST) 
             (foreach x lst 
               (setq ss  (xyp-Ssdel sss x) 
                     sss ss 
               ) 
             ) 
            ) 
      ) 
      ss 
    ) 
  ) 
)

xyp1964 · 发表于 2012-8-3 00:35

本帖最后由 xyp1964 于 2019-1-26 17:05 编辑

;; xyp-R2D 弧度转角度 (xyp-R2D rad)
(defun xyp-R2D (rad) (* (/ rad pi) 180.0))
;; xyp-D2R 角度转弧度 (xyp-D2R ang)
(defun xyp-D2R (ang) (* (/ ang 180.0) pi))
;; xyp-get-tblnext 获得特定符号表的列表 (xyp-get-tblnext "Block")
;; 有效符号表名称为Layer、Ltype、View、Style、Block、Appid、Ucs、Dimstyle 和 Vport
(defun xyp-get-tblnext (table-name / lst d)
(while (setq d (tblnext table-name (null d)))
(setq lst (cons (cdr (assoc 2 d)) lst))
)
(vl-sort lst '<)
)

自贡黄明儒 · 发表于 2012-8-3 08:35

精品啊！向院长致敬！支持源码!

yoyoho · 发表于 2012-8-3 09:40

感谢 xyp1964 版主分享源码程序!

随梦而飞 · 发表于 2012-8-3 09:52

看了院长的，应一个实用演示图加一个LISP源码，我是大陆人，看这些有点费劲

junkegg · 发表于 2012-8-3 18:31

没人点评的了，我来。精精精

c735023723 · 发表于 2012-8-3 20:38

很好，很强大，院长就是院长啊，呵呵

xyp1964 · 发表于 2012-8-3 21:00

本帖最后由 xyp1964 于 2019-1-26 17:06 编辑

;; xyp-Join-Line 直线消重 (xyp-Join-Line ename1 ename2)
(defun xyp-Join-Line (e1 e2 / p1 p2 p3 p4 ptn p10 p11)
(if (and (not (equal e1 e2))
(xyp-Etype e1 "LINE")
(xyp-Etype e2 "LINE")
)
(progn
(setq p1 (xyp-get-dxf 10 e1)
p2 (xyp-get-dxf 11 e1)
p3 (xyp-get-dxf 10 e2)
p4 (xyp-get-dxf 11 e2)
)
(if (and (XYP-3PointAtLine p1 p2 p3)
(XYP-3PointAtLine p1 p2 p4)
)
(progn
(setq ptn (xyp-Sort-ptnByXYZ (list p1 p2 p3 p4))
p10 (car ptn)
p11 (last ptn)
)
(entdel e2)
(xyp-SUBUPD e1 10 p10)
(xyp-SUBUPD e1 11 p11)
t
)
nil
)
)
nil
)
)
;; XYP-3PointAtLine 3点共线 (XYP-3PointAtLine p1 p2 p3)
(defun XYP-3PointAtLine (p1 p2 p3 / dl d1 d2 d3)
(setq dl 1e-5
d1 (distance p1 p2)
d2 (distance p2 p3)
d3 (distance p1 p3)
)
(if (or (equal (+ d3 d2) d1 dl)
(equal (+ d1 d2) d3 dl)
(equal (+ d1 d3) d2 dl)
)
t
nil
)
)
;; xyp-Sort-ptnByXYZ 点表按照xyz从小到大排序 (xyp-Sort-ptnByXYZ ptn)
(defun xyp-Sort-ptnByXYZ (ptn / p1 p2)
(vl-sort ptn
'(lambda (p1 p2)
(cond ((< (car p1) (car p2)) T)
((and (= (car p1) (car p2))
(< (cadr p1) (cadr p2))
)
T
)
((and (= (car p1) (car p2))
(= (cadr p1) (cadr p2))
(< (caddr p1) (caddr p2))
)
T
)
(T nil)
)
)
)
)
;; 应用实例
;; gxyh(共线优化)
(defun c:tt ()
(setq ss (ssget '((0 . "line")))
i -1
lst '()
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq j i)
(if (not (member s1 lst))
(while (setq s2 (ssname ss (setq j (1+ j))))
(if (not (member s2 lst))
(if (xyp-Join-Line s1 s2)
(setq lst (cons s2 lst))
)
)
)
)
)
(princ)
)

;; xyp-Join-Line 直线消重 (xyp-Join-Line ename1 ename2) 
(defun xyp-Join-Line (e1 e2 / p1 p2 p3 p4 ptn p10 p11) 
  (if (and (not (equal e1 e2)) 
    (xyp-Etype e1 "LINE") 
    (xyp-Etype e2 "LINE") 
      ) 
    (progn 
      (setq p1 (xyp-get-dxf 10 e1) 
     p2 (xyp-get-dxf 11 e1) 
     p3 (xyp-get-dxf 10 e2) 
     p4 (xyp-get-dxf 11 e2) 
      ) 
      (if (and (XYP-3PointAtLine p1 p2 p3) 
        (XYP-3PointAtLine p1 p2 p4) 
   ) 
 (progn 
   (setq ptn (xyp-Sort-ptnByXYZ (list p1 p2 p3 p4)) 
  p10 (car ptn) 
  p11 (last ptn) 
   ) 
   (entdel e2) 
   (xyp-SUBUPD e1 10 p10) 
   (xyp-SUBUPD e1 11 p11) 
   t 
 ) 
 nil 
      ) 
    ) 
    nil 
  ) 
) 
;; XYP-3PointAtLine 3点共线 (XYP-3PointAtLine p1 p2 p3) 
(defun XYP-3PointAtLine (p1 p2 p3 / dl d1 d2 d3) 
  (setq dl  1e-5 
 d1  (distance p1 p2) 
 d2  (distance p2 p3) 
 d3  (distance p1 p3) 
  ) 
  (if (or (equal (+ d3 d2) d1 dl) 
   (equal (+ d1 d2) d3 dl) 
   (equal (+ d1 d3) d2 dl) 
      ) 
    t 
    nil 
  ) 
) 
;; xyp-Sort-ptnByXYZ 点表按照xyz从小到大排序 (xyp-Sort-ptnByXYZ ptn) 
(defun xyp-Sort-ptnByXYZ (ptn / p1 p2) 
  (vl-sort ptn 
    '(lambda (p1 p2) 
       (cond ((< (car p1) (car p2)) T) 
      ((and (= (car p1) (car p2)) 
     (< (cadr p1) (cadr p2)) 
       ) 
       T 
      ) 
      ((and (= (car p1) (car p2)) 
     (= (cadr p1) (cadr p2)) 
     (< (caddr p1) (caddr p2)) 
       ) 
       T 
      ) 
      (T nil) 
       ) 
     ) 
  ) 
) 
;; 应用实例 
;; gxyh(共线优化) 
(defun c:tt () 
  (setq ss  (ssget '((0 . "line"))) 
 i   -1 
 lst '() 
  ) 
  (while (setq s1 (ssname ss (setq i (1+ i)))) 
    (setq j i) 
    (if (not (member s1 lst)) 
      (while (setq s2 (ssname ss (setq j (1+ j)))) 
 (if (not (member s2 lst)) 
   (if (xyp-Join-Line s1 s2) 
     (setq lst (cons s2 lst)) 
   ) 
 ) 
      ) 
    ) 
  ) 
  (princ) 
)

xiaodao520 · 发表于 2012-8-3 21:21

xyp1964 发表于 2012-8-3 21:00

太花哨了没实际意用处。

caoliu023 · 发表于 2012-8-3 21:43

感谢分享1111111

账号		自动登录	找回密码
密码			注册

[讨论] 【e派】工具箱函数再揭秘及应用实例

点评

评分

本帖子中包含更多资源

点评