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

yoyoho

感谢 xyp1964 版主分享函数!

smartstar

支持院长。

xiaxiang

连院长都打算开源了，别人的代码还有捂着的必要吗

pzweng

学习了,

longer1000

支持院长，支持源码

chpmould

very good!
LISP open-source moment.

cable2004

强烈支持院长！

xiaoyingzi

院长的源码，来学习

xyp1964

;; 先来个伪源码的看看效果

1. ;; zttc(总图停车)
   
2. (defun c:zttc (/ ilst ll1 ll2)
   
3.   (cmdla0)
   
4.   (defun main-pro (/ ss i s1 an w l ss dl dw i num ptn ptn1 ptn2 pt s2 n1 tx)
   
5.     (princ "\n选择曲线: ")
   
6.     (if (< ang 45)
   
7.       (setq an 90
   
8.      w  (+ leng 0.5)
   
9.      l  (- wide 1)
   
10.       )
    
11.       (setq an ang
    
12.      w  wide
    
13.      l  leng
    
14.       )
    
15.     )
    
16.     (setq ss  (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))
    
17.    dl  (+ l (* w (xyp-TAN (xyp-d2r (- 90 an)))))
    
18.    dw  (/ w (sin (xyp-d2r an)))
    
19.    i   -1
    
20.    num 0
    
21.     )
    
22.     (while (setq s1 (ssname ss (setq i (1+ i))))
    
23.       (xyp-Group0)
    
24.       (setq ptn (xyp-CurveDivDistBetweenPtn s1 dw))
    
25.       (foreach ptn1 ptn
    
26. (xyp-MkLaCo "总图停车" 8)
    
27. (foreach pt ptn1
    
28.    (setq s2 (xyp-Faxian s1 pt dl))
    
29.    (xyp-rotate s2 pt (- an 90))
    
30. )
    
31. (if (= bo1 "1")
    
32.    (progn
    
33.      (xyp-MkLaCo "总图停车数量" 4)
    
34.      (setq pt  (xyp-Get-RightPoint (car ptn1) (last ptn1) (* l 0.5))
    
35.     n1  (- (length ptn1) 1)
    
36.     num (+ n1 num)
    
37.     tx  (itoa n1)
    
38.     s2  (xyp-Text 5 pt tx)
    
39.      )
    
40.    )
    
41. )
    
42.       )
    
43.       (xyp-Group1)
    
44.     )
    
45.     (if (= bo1 "1")
    
46.       (progn
    
47. (xyp-Text 5 '(0 0) (strcat "停车数量 ＝ " (itoa num)))
    
48. (xyp-GrreadMove (entlast) '(0 0))
    
49.       )
    
50.     )
    
51.   )
    
52.   (setq ll1 '(wide leng ang bo1)
    
53. ll2 '(3. 5. 90. "1")
    
54.   )
    
55.   (defun ajbcs () (xyp-Multiple-Settile ll1 ll2))
    
56.   (xyp-initSet ll1 ll2)
    
57.   (setq ilst '(("k0" "" "imagebutton" "-2" "24" "zongtutingche" "(princ)")
    
58.         "spacer;"
    
59.         ("" "车位参数" ":boxed_column{")
    
60.         ("wide" "宽度(W)" "real" "8")
    
61.         ("leng" "长度(L)" "real" "8")
    
62.         ("ang" "角度(a)" "real" "8")
    
63.         "spacer;"
    
64.         ("bo1" "标数量" "bool")
    
65.         "spacer;"
    
66.         "}"
    
67.         "spacer;"
    
68.         ("jbcs" "缺省参数" "button1" "(ajbcs)")
    
69.         "spacer;"
    
70.         "ioc"
    
71.        )
    
72.   )
    
73.   (if (= (xyp-Dcl-Init Ilst "【总图停车】" t) 1)
    
74.     (main-pro)
    
75.   )
    
76.   (cmdla1)
    
77. )
    

;; zttc(总图停车)<br /> (defun c:zttc (/ ilst ll1 ll2)<br />   (cmdla0)<br />   (defun main-pro (/ ss i s1 an w l ss dl dw i num ptn ptn1 ptn2 pt s2 n1 tx)<br />     (princ "\n选择曲线: ")<br />     (if (< ang 45)<br />       (setq an 90<br />      w  (+ leng 0.5)<br />      l  (- wide 1)<br />       )<br />       (setq an ang<br />      w  wide<br />      l  leng<br />       )<br />     )<br />     (setq ss  (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))<br />    dl  (+ l (* w (xyp-TAN (xyp-d2r (- 90 an)))))<br />    dw  (/ w (sin (xyp-d2r an)))<br />    i   -1<br />    num 0<br />     )<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (xyp-Group0)<br />       (setq ptn (xyp-CurveDivDistBetweenPtn s1 dw))<br />       (foreach ptn1 ptn<br /> (xyp-MkLaCo "总图停车" 8)<br /> (foreach pt ptn1<br />    (setq s2 (xyp-Faxian s1 pt dl))<br />    (xyp-rotate s2 pt (- an 90))<br /> )<br /> (if (= bo1 "1")<br />    (progn<br />      (xyp-MkLaCo "总图停车数量" 4)<br />      (setq pt  (xyp-Get-RightPoint (car ptn1) (last ptn1) (* l 0.5))<br />     n1  (- (length ptn1) 1)<br />     num (+ n1 num)<br />     tx  (itoa n1)<br />     s2  (xyp-Text 5 pt tx)<br />      )<br />    )<br /> )<br />       )<br />       (xyp-Group1)<br />     )<br />     (if (= bo1 "1")<br />       (progn<br /> (xyp-Text 5 '(0 0) (strcat "停车数量 ＝ " (itoa num)))<br /> (xyp-GrreadMove (entlast) '(0 0))<br />       )<br />     )<br />   )<br />   (setq ll1 '(wide leng ang bo1)<br /> ll2 '(3. 5. 90. "1")<br />   )<br />   (defun ajbcs () (xyp-Multiple-Settile ll1 ll2))<br />   (xyp-initSet ll1 ll2)<br />   (setq ilst '(("k0" "" "imagebutton" "-2" "24" "zongtutingche" "(princ)")<br />         "spacer;"<br />         ("" "车位参数" ":boxed_column{")<br />         ("wide" "宽度(W)" "real" "8")<br />         ("leng" "长度(L)" "real" "8")<br />         ("ang" "角度(a)" "real" "8")<br />         "spacer;"<br />         ("bo1" "标数量" "bool")<br />         "spacer;"<br />         "}"<br />         "spacer;"<br />         ("jbcs" "缺省参数" "button1" "(ajbcs)")<br />         "spacer;"<br />         "ioc"<br />        )<br />   )<br />   (if (= (xyp-Dcl-Init Ilst "【总图停车】" t) 1)<br />     (main-pro)<br />   )<br />   (cmdla1)<br /> )<br />

xyp1964

1. ;; CheckPtn 删除重复点表 (CheckPtn ptn 500)
   
2. (defun CheckPtn (ptn fuzz / lst p1 lst-t pt)
   
3.   (setq lst '())
   
4.   (while (>= (length ptn) 1)
   
5.     (setq p1 (car ptn)
   
6.    ptn (cdr ptn)
   
7.    lst (cons p1 lst)
   
8.    lst-t '()
   
9.     )
   
10.     (foreach pt ptn
    
11.       (if (>= (distance p1 pt) fuzz)
    
12. (setq lst-t (cons pt lst-t))
    
13.       )
    
14.     )
    
15.     (setq ptn (reverse lst-t))
    
16.   )
    
17.   lst
    
18. )
    
19. ;; 实例：优化多段线，长度小于500的顶点取消
    
20. (defun c:tt ()
    
21.   (setq s1  (car (entsel "\n选择多段线: "))
    
22. ptn (xyp-get-Vertexs s1 0)
    
23. ptn (CheckPtn ptn 500)
    
24.   )
    
25.   (xyp-Entmake-lwPolyline ptn nil)
    
26.   (princ)
    
27. )
    

;; CheckPtn 删除重复点表 (CheckPtn ptn 500)<br /> (defun CheckPtn (ptn fuzz / lst p1 lst-t pt)<br />   (setq lst '())<br />   (while (>= (length ptn) 1)<br />     (setq p1 (car ptn)<br />    ptn (cdr ptn)<br />    lst (cons p1 lst)<br />    lst-t '()<br />     )<br />     (foreach pt ptn<br />       (if (>= (distance p1 pt) fuzz)<br /> (setq lst-t (cons pt lst-t))<br />       )<br />     )<br />     (setq ptn (reverse lst-t))<br />   )<br />   lst<br /> )<br /> ;; 实例：优化多段线，长度小于500的顶点取消<br /> (defun c:tt ()<br />   (setq s1  (car (entsel "\n选择多段线: "))<br /> ptn (xyp-get-Vertexs s1 0)<br /> ptn (CheckPtn ptn 500)<br />   )<br />   (xyp-Entmake-lwPolyline ptn nil)<br />   (princ)<br /> )<br />