求大佬帮完善代码！

fengyu6913

以下为之前在论坛上的代码，实现块统计与排列
需进步完善下：
排列前将待排列的块的XYZ的比例均调整为1，块的旋转角度为0
排列时保证块图形的左下角为对齐点
多功能块名需要正常显示

原贴：http://bbs.mjtd.com/thread-190240-1-1.html





;|**************************************************************
版权所有: xtjd                                                 *
程序用途: 图块统计与排列                                       *
日期地点: 2024.05.24 KS                                        *
程序语言: AutoLISP,Visual LISP                                 *
版本号:   Ver. 1.0.24.0524                                     *
===============================================================*
===============================================================*
本程序为开源代码，下述为开源申明:                              
----------------------------------------------------------------
本页面的程序遵照以下协议开放源代码
一.                              
二.                       
三.                             
================================================================
**************************************************************|;
(defun c:dyy(/ bn d> di ds es i< in is nb nn ns os p0 pi1 pt ss st str t1 t2 t3 t4 t5)
        (defun t1(a / b)(while(setq b(cons(list(car a)(-(length a)(length(vl-remove(car a)a))))b)a(vl-remove(car a)a)))(reverse b))
        (defun t2(obj / p1 p2)(vla-getboundingbox obj 'p1 'p2)(mapcar 'vlax-safearray->list (list p1 p2)))
        (defun t3(n p)(entmakex(list '(0 . "INSERT") (cons 2 n) (cons 10 p))))
        (defun t4(pt str)(entmake(list'(0 . "TEXT")(cons 10 pt)(cons 1 str)'(40 . 20)'(62 . 10)(cons 7(getvar "textstyle")))))
        (defun t5(p1 p2)(entmake(list '(0 . "LINE")(cons 10 p1)(cons 11 p2))))
        (setvar "cmdecho" 0)
        (if(and
                         (setq ss(ssget '((0 . "INSERT"))))
                         (setq pt(getpoint "\n请指定排列起点:"))
                 )
                (progn
                        (setq
                                es(vl-remove-if 'listp(mapcar 'cadr(ssnamex ss)))
                                os(mapcar 'vlax-ename->vla-object es)
                                ns(mapcar 'vla-get-name os)
                                is(t1 ns)
                                i<(vl-sort is '(lambda(a b)(<(car a)(car b))))
                                in(length i<)
                                ds(mapcar 't2 os)
                                d>(apply 'max(mapcar '(lambda(x)(-(caadr x)(caar x)))ds))
                                di(* d> 2)
                                pi1(* pi 1.5)
                                st 0
                        )
                        (t5 pt(polar pt 0(* di in)))
                        (repeat in
                                (setq        str(nth st i<) bn(car str) st(1+ st))
                                (t5 pt(polar pt pi1 150))
                                (t4(polar pt pi1 50)bn)
                                (t4(polar pt pi1 100)(strcat "块数量:"(itoa(cadr str))))
                                (setq
                                        nn(vl-position bn ns)
                                        nb(vla-copy(nth nn os))
                                        p0(car(nth nn ds))
                                )
                                (vla-move nb(vlax-3d-point p0)(vlax-3d-point pt))
                                (setq pt(polar pt 0 di))
                        )
                )
        )
        (prin1)
)

fengyu6913

自己顶一下

xyp1964

1. (defun c:tt ()
   
2.   "tt(图块统计与排列)"
   
3.   (defun t1 (a / b)
   
4.     (while (setq b (cons (list (car a) (- (length a) (length (vl-remove (car a) a))))
   
5.                          b
   
6.                    )
   
7.                  a (vl-remove (car a) a)
   
8.            )
   
9.     )
   
10.     (reverse b)
    
11.   )
    
12.   (defun p1p9 (obj / p1 p2)
    
13.     (vla-getboundingbox obj 'p1 'p2)
    
14.     (mapcar 'vlax-safearray->list (list p1 p2))
    
15.   )
    
16.   (defun mk-in (bn pt)
    
17.     (entmakex (list '(0 . "INSERT") (cons 2 bn) (cons 10 pt)))
    
18.   )
    
19.   (defun mk-text (pt str)
    
20.     (entmake (list '(0 . "TEXT")
    
21.                    (cons 10 pt)
    
22.                    (cons 1 str)
    
23.                    '(40 . 20)
    
24.                    '(62 . 10)
    
25.                    (cons 7 (getvar "textstyle"))
    
26.              )
    
27.     )
    
28.   )
    
29.   (defun Mk-line (p1 p2)
    
30.     (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
    
31.   )
    
32.   (setvar "cmdecho" 0)
    
33.   (if (and (setq ss (ssget '((0 . "INSERT"))))
    
34.            (setq pt (getpoint "\n请指定排列起点: "))
    
35.       )
    
36.     (progn
    
37.       (setq p00 pt
    
38.             os  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    
39.             os  (mapcar 'vlax-ename->vla-object os)
    
40.             os  (mapcar 'vla-get-name os)
    
41.             lst (vl-sort (t1 os) '(lambda (a b) (< (car a) (car b))))
    
42.             pii (* pi 1.5)
    
43.             st  0
    
44.       )
    
45.       (foreach a lst
    
46.         (setq bn  (car a)
    
47.               nn  (cadr str)
    
48.               s1  (mk-in bn pt)
    
49.               ptn (p1p9 (vlax-ename->vla-object s1))
    
50.               p1  (car ptn)
    
51.               p9  (cadr ptn)
    
52.               dd  (- (car p9) (car p1))
    
53.         )
    
54.         (command "Move" s1 "" "non" p1 "non" pt)
    
55.         (Mk-line pt (polar pt pii 150))
    
56.         (mk-text (polar pt pii 50) bn)
    
57.         (mk-text (polar pt pii 100) (strcat "块数量:" (itoa nn)))
    
58.         (setq pt (polar pt 0 (+ dd 500)))
    
59.       )
    
60.       (Mk-line p00 pt)
    
61.     )
    
62.   )
    
63.   (princ)
    
64. )

(defun c:tt ()<br />   "tt(图块统计与排列)"<br />   (defun t1 (a / b)<br />     (while (setq b (cons (list (car a) (- (length a) (length (vl-remove (car a) a))))<br />                          b<br />                    )<br />                  a (vl-remove (car a) a)<br />            )<br />     )<br />     (reverse b)<br />   )<br />   (defun p1p9 (obj / p1 p2)<br />     (vla-getboundingbox obj 'p1 'p2)<br />     (mapcar 'vlax-safearray->list (list p1 p2))<br />   )<br />   (defun mk-in (bn pt)<br />     (entmakex (list '(0 . "INSERT") (cons 2 bn) (cons 10 pt)))<br />   )<br />   (defun mk-text (pt str)<br />     (entmake (list '(0 . "TEXT")<br />                    (cons 10 pt)<br />                    (cons 1 str)<br />                    '(40 . 20)<br />                    '(62 . 10)<br />                    (cons 7 (getvar "textstyle"))<br />              )<br />     )<br />   )<br />   (defun Mk-line (p1 p2)<br />     (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))<br />   )<br />   (setvar "cmdecho" 0)<br />   (if (and (setq ss (ssget '((0 . "INSERT"))))<br />            (setq pt (getpoint "\n请指定排列起点: "))<br />       )<br />     (progn<br />       (setq p00 pt<br />             os  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))<br />             os  (mapcar 'vlax-ename->vla-object os)<br />             os  (mapcar 'vla-get-name os)<br />             lst (vl-sort (t1 os) '(lambda (a b) (< (car a) (car b))))<br />             pii (* pi 1.5)<br />             st  0<br />       )<br />       (foreach a lst<br />         (setq bn  (car a)<br />               nn  (cadr str)<br />               s1  (mk-in bn pt)<br />               ptn (p1p9 (vlax-ename->vla-object s1))<br />               p1  (car ptn)<br />               p9  (cadr ptn)<br />               dd  (- (car p9) (car p1))<br />         )<br />         (command "Move" s1 "" "non" p1 "non" pt)<br />         (Mk-line pt (polar pt pii 150))<br />         (mk-text (polar pt pii 50) bn)<br />         (mk-text (polar pt pii 100) (strcat "块数量:" (itoa nn)))<br />         (setq pt (polar pt 0 (+ dd 500)))<br />       )<br />       (Mk-line p00 pt)<br />     )<br />   )<br />   (princ)<br /> )