方格排序 感谢73哥等大神函数

树櫴希德

方格排序 感谢73哥等大神函数

2. (defun zxzb (pts / len pt )
   
3.   (setq len (length pts))
   
4. (setq pt (mapcar
   
5.   '(lambda(x)
   
6.     (/ x len)
   
7.   )
   
8.   (apply
   
9.     'mapcar
   
10.     (cons '+ pts)
    
11.   )
    
12. )
    
13. )  pt)
    
14. 
    
15. 
    
16. (defun Plinexy(e / p a b n ob q et d d1 en et)
    
17.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    
18.     (cond((="LWPOLYLINE"et)
    
19.     (repeat(length a)(setq b (nth n a) n (+ n 1))
    
20.       (if (= 10 (car b))(progn
    
21.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
    
22.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
    
23.           (setq p (list q)))))))
    
24.    ((="POLYLINE"et)
    
25.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    
26.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
    
27.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
    
28.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
    
29.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    
30.     (setq p(reverse p))))P)
    
31. 
    
32. (defun cx-ss2en
    
33.   (ss / enlst)
    
34.   (cond
    
35.     ((= (type ss) 'PICKSET)
    
36.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
    
37.     )
    
38.     ((= (type ss) 'LIST)
    
39.       (setq enlst (ssadd))
    
40.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
41.     )
    
42.     ((='ename(type ss))
    
43.       (ssadd ss)
    
44.     )
    
45.   )
    
46. )
    
47.   ;;;;;;;;;;;;;;;;;;
    
48. (defun t2t (p1 p2 p3 / p1 p2 p3) ;点到直线距离1
    
49.   
    
50. 
    
51.   (abs (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1))))
    
52.   
    
53. )   ;;;;;;;;;;;;;;;;
    
54. 
    
55. (defun t1t (p1 p2 p3 / p1 p2 p3) ;点到直线距离2
    
56.   
    
57. 
    
58.    (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1)))
    
59.   
    
60. )
    
61. 
    
62. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
63. (defun c:szpx (/ ssa kongbiao i ii zb paixuzb p1 p2 fgjj p3 cishu kb kbb iii)
    
64. (setq ssa (ssget "x"'( (0 . "polyline")  (8 . "tf-fg1") ) ) )
    
65. (setq kongbiao '()) (setq i 0)
    
66. (foreach x (cx-ss2en ssa)
    
67.      
    
68.     (setq zb (zxzb(plinexy x))) (setq kongbiao (append (list zb) kongbiao)) (setq i (1+ i))
    
69.   )
    
70. 
    
71. (setq paixuzb (vl-sort kongbiao
    
72.              (function (lambda (e1 e2)      (> (cadr e1)(cadr e2 ) )   
    
73.               ) ) )
    
74.        )
    
75. (setq p1 (getpoint "\n请选择直线起点："))
    
76.   (setq p2 (getpoint "\n请选择直线第二点："))
    
77. (setq fgjj (getint "\n请输入方格间距(输入整数)："));输入整数
    
78.   (setq p3 (last paixuzb))
    
79. (setq cishu (+ 2 (fix (/ (t2t p1 p2 p3) fgjj )  ) ) )
    
80. (setq kb '()) (setq ii 0)
    
81. (repeat cishu
    
82.    
    
83. 
    
84. (setq kbb
    
85. (vl-sort (vl-remove-if-not  (FUNCTION (LAMBDA (A1) (< (* -1 fgjj) (t1t (polar p1 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) (polar p2 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) A1) 0) ))  kongbiao)
    
86.              (function (lambda (e1 e2)      (> (car e1)(car e2 ) )   
    
87.               ) ) )
    
88. 
    
89. )  
    
90. (setq kb (append kbb kb))
    
91. 
    
92. (setq ii (1+ ii))
    
93. 
    
94. 
    
95.   )
    
96.   (setq iii 0)
    
97. (foreach n (reverse kb)
    
98. 
    
99. 
    
100.    (entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos (+ iii 1) 2 0)) (cons 10 n ) (cons 40 1.0)))
     
101.   (entmake (list '(0 . "circle") '(8 . "fgbj")(cons 62 3) (cons 10 n ) (cons 40 1.0)))
     
102. (setq iii (1+ iii))
     
103. 
     
104.   )
     
105. 
     
106. (princ)
     
107. )

(defun zxzb (pts / len pt )<br />   (setq len (length pts))<br /> (setq pt (mapcar<br />   '(lambda(x)<br />     (/ x len)<br />   )<br />   (apply<br />     'mapcar<br />     (cons '+ pts)<br />   )<br /> )<br /> )  pt)<br /> <br /> <br /> (defun Plinexy(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="POLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> <br /> (defun cx-ss2en<br />   (ss / enlst)<br />   (cond<br />     ((= (type ss) 'PICKSET)<br />       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />     )<br />     ((= (type ss) 'LIST)<br />       (setq enlst (ssadd))<br />       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />     )<br />     ((='ename(type ss))<br />       (ssadd ss)<br />     )<br />   )<br /> )<br />   ;;;;;;;;;;;;;;;;;;<br /> (defun t2t (p1 p2 p3 / p1 p2 p3) ;点到直线距离1<br />   <br /> <br />   (abs (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1))))<br />   <br /> )   ;;;;;;;;;;;;;;;;<br /> <br /> (defun t1t (p1 p2 p3 / p1 p2 p3) ;点到直线距离2<br />   <br /> <br />    (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1)))<br />   <br /> )<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun c:szpx (/ ssa kongbiao i ii zb paixuzb p1 p2 fgjj p3 cishu kb kbb iii)<br /> (setq ssa (ssget "x"'( (0 . "polyline")  (8 . "tf-fg1") ) ) )<br /> (setq kongbiao '()) (setq i 0)<br /> (foreach x (cx-ss2en ssa)<br />      <br />     (setq zb (zxzb(plinexy x))) (setq kongbiao (append (list zb) kongbiao)) (setq i (1+ i))<br />   )<br /> <br /> (setq paixuzb (vl-sort kongbiao<br />              (function (lambda (e1 e2)      (> (cadr e1)(cadr e2 ) )   <br />               ) ) )<br />        )<br /> (setq p1 (getpoint "\n请选择直线起点："))<br />   (setq p2 (getpoint "\n请选择直线第二点："))<br /> (setq fgjj (getint "\n请输入方格间距(输入整数)："));输入整数<br />   (setq p3 (last paixuzb))<br /> (setq cishu (+ 2 (fix (/ (t2t p1 p2 p3) fgjj )  ) ) )<br /> (setq kb '()) (setq ii 0)<br /> (repeat cishu<br />     <br /> <br /> (setq kbb<br /> (vl-sort (vl-remove-if-not  (FUNCTION (LAMBDA (A1) (< (* -1 fgjj) (t1t (polar p1 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) (polar p2 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) A1) 0) ))  kongbiao)<br />              (function (lambda (e1 e2)      (> (car e1)(car e2 ) )   <br />               ) ) )<br /> <br /> )  <br /> (setq kb (append kbb kb))<br /> <br /> (setq ii (1+ ii))<br /> <br /> <br />   )<br />   (setq iii 0)<br /> (foreach n (reverse kb)<br /> <br /> <br />    (entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos (+ iii 1) 2 0)) (cons 10 n ) (cons 40 1.0)))<br />   (entmake (list '(0 . "circle") '(8 . "fgbj")(cons 62 3) (cons 10 n ) (cons 40 1.0)))<br /> (setq iii (1+ iii))<br /> <br />   )<br /> <br /> (princ)<br /> )

树櫴希德

欢迎下载 改进

winerfjy

好贴！估计楼主也花了不少时间写这个代码

13648893846

选择直线起点是只能选择最北的直线并且得从右往左选择,不然就出错,能否优化一下

血司

血司

(defun c:lxybh (/ str k qz ss xxpx xxss zg)
        (setq ss (ssget (list '(0 . "*LWPOLYLINE")))
              zg (getreal"\n请输入标注字高：")
              qz (getstring"\n请输入前缀：")
        )
        (setq xxss nil)
        (foreach cc (lxy-ss->list ss)
                (setq xxss (append (list (lxy-poly-cen (lxy-poly-pts cc))) xxss))
        )
        (setq xxpx (lxy-pts-xy xxss 1 0))
        (setq k 0)
        (foreach aa xxpx
                (if (= qz nil)
                        (setq str (itoa (1+ k)))
                        (setq str (strcat qz (itoa (1+ k))))
                )
                (maketext aa str zg)
        )
        (princ)
)

zst1978

非常谢谢大侠分享

skg123

你就是测绘板块的 劳模