Some expert programs

Thread Content

This post was last edited by aicr317 on 2010-4-2 15:48;;intersection list (defun yad_inters(ss / n n1 obj1 n2 obj2 ipt l_pt) (setq n (sslength ss) n1 0 ) (while ( < n1 (1- n)) (setq obj1 (vlax-ename-> vla-object (ssname ss n1)) n2 (1+ n1) ) (while ( < n2 n) (setq obj2 (vlax-ename-> vla-object (ssname ss n2)) ipt (vlax-variant-value (vla-intersectwith obj1 obj2 0)) ) (if (&gt; (vlax-safearray-get-u-bound ipt 1) 0) (progn (setq ipt (vlax-safearray-&gt;list ipt)) (while (&gt; (length ipt) 0) (setq l_pt (cons (list (car ipt) (cadr ipt) (caddr ipt)) l_pt) ipt (cdddr ipt)) ) ) ) (setq n2 (1+ n2)) ) (setq n1 (1+ n1)) ) l_pt ) ;;Compound line vertex list (defun yad_ptlst(en/nl_pt l_p) (if (not (listp en)) (setq en (entget en))) (setq n (vl-position (assoc 10 en) en)) (repeat (- (length en) n) (if (= (car (nth n en)) 10) (setq l_pt (append l_pt (list (cdr (nth n en))))) ) (setq n (1+ n)) ) (foreach nl_pt (if (not (vl-member-if \'(lambda(x) (equal xn 0.01)) l_p)) (setq l_p (append l_p (list n))) ) ) l_p ) ;;Compound line turning point list (defun yad_cptlst(l_pt/l_pv p1 p2 ang ang1 np pd) (setq l_pt (append l_pt (list (car l_pt))) l_pv (list (setq p1 (nth 0 l_pt)) (setq p2 (nth 1 l_pt))) ang (angle p1 p2) ang1 ang n 2 ) (while (setq p (nth nl_pt)) (setq pd p2) (if (equal ang (angle p2 p) 0.01) (setq l_pv (subst p p2 l_pv) p2 p ) (setq ang (angle p2 p) p2 pl_pv (append l_pv (list p)) ) ) (setq n (1+ n)) ) (if (equal ang1 (angle pd p2) 0.01) (setq l_pv (vl-remove p2 l_pv)) (setq l_pv (reverse (cdr (reverse l_pv)))) ) l_pv ) ;;Find the two diagonal points of the screen (defun yad_viewpt(/ abcdx) (setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize")) a ( * b (/ cd)) x (trans (getvar "viewctr") 1 2) c (trans (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0) 2 1) d (trans (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) 2 1) ) (list cd) ) ;;Generate unnamed group (defun yad_group(lst / en1 name en ent) (setq lst (mapcar \'(lambda(e) (cons 340 e)) lst)) (setq en1 (dictsearch (namedobjdict) "ACAD_GROUP")) (if (member (cons 3 " * A1") en1) (setq name (strcat " * A" (itoa (1+ (atoi (substr (cdr (assoc 3 (reverse en1)))) 3))))) (setq name " * A1") ) (setq en (list (cons 0 "GROUP") (cons 102 "{ACAD_REACTORS") (cons 330 (dxf en1 -1)) (cons 102 "}") (cons 100 "AcDbGroup") (cons 70 1) (cons 71 1) ) ) (setq ent (entmakex (append en lst)) en1 (append en1 (list (cons 3 name) (cons 350 ent))) ) (entmod en1) ) ;;Scale the screen to ensure that the object is within the screen (defun yad_zoom(lst / maxmin lsttrans ab zmpt) (defun maxmin(lst / xnabcd) (setq x (car lst) a (car x) b (cadr x) c (car x) d (cadr x) n 1 ) (repeat (max (- (length lst) 1) 0) (setq x (nth n lst) a (min a (car x)) b (min b (cadr x)) c (max c (car x)) d (max d (cadr x)) n (1+ n) ) ) (list (list ab) (list cd)) ) (defun lsttrans(lst ab / lst2 cn) (setq n 0) (repeat (length lst) (setq c (trans (nth n lst) ab) lst2 (append lst2 (list c)) n (1+ n) ) ) lst2 ) (setq lst (maxmin (lsttrans lst 1 2)) a (car lst) b (cadr lst) lst (list (list (- (car a) 4000) (- (cadr a) 4000)) (list (+ (car b) 4000) (+ (cadr b) 4000))) a (maxmin (lsttrans (viewpnts) 1 2)) b (maxmin (append a lst)) zmpt (list (trans (append (car b) \'(0.0)) 2 1) (trans (append (cadr b) \'(0.0)) 2 1)) ) (command "_.zoom" "_w" (car zmpt) (cadr zmpt)) zmpt ) ;;Check the legality of the value entered in the dialog box (defun yad_chkval(title ma * nt minint oldval / val) (setq val (atof (get_tile title))) (if (&gt;= ma * nt val minint) (set_tile title (rtos val)) (set_tile title oldval) ) ) ;;Check the validity of integer input (defun yad_chkint(pmt defval ma * nt minint / val pd) (if (/= defval "no") (setq pmt (strcat pmt "") defval (atoi defval))) (setq pd T) (while (and pd (setq val (getint pmt)))) (if (&gt;= ma * nt val minint) (setq pd nil val val) (prompt "Invalid input!" ") ) ) (if (and (/= defval "no") (not val)) (setq val defval)) (if (&gt;= ma * nt val minint) val (if (/= defval "no") (prompt "\\nThe default value is invalid! ") ) ) ) ;;Select set merge(defun yad_ssadd(oldss ss / n) (setq n -1) (repeat (sslength ss) (ssadd (ssname ss (setq n (1+ n))) oldss) ) oldss ) ;;Select the object of point features (defun yad_ssget(dis xyz / nm) (setq z (append z \'((-4 . " (setq n 0) (repeat (length x) (setq m 0) (repeat (length y) (setq z (append z (list(cons -4 " (cons -4 "=") (cons (nth nx) (mapcar \'(lambda(e) (- e dis)) (nth my)) ) (cons -4 "and&gt;") ) ) ) (setq m (1+ m)) ) (setq n (1+ n)) ) (setq z (append z \'((-4 . "or&gt;")))) (ssget "x" z) ) ;;Modify object (defun yad_chgent(en n new) (if (not (listp en)) (setq en (entget en))) (if (assoc n en) (setq en (subst (cons n new) (assoc n en) en)) (setq en (append en (list (cons n new)))) ) (entmod en) ) ;;Delete the specified position entry of the table (defun yad_remove(nm lst / n newlst) (setq n 0) (repeat (length lst) (if (/= nm n) (setq newlst (append newlst (list (nth n lst)))) ) (setq n (1+ n)) ) newlst ) ;;String to list (defun yad_str2lst(str st / lst) (setq str (strcat str st)) (while (vl-string-search st str) (setq lst (append lst (list (substr str 1 (vl-string-search st str))))) (setq str (substr str (+ (1+ (strlen st)) (vl-string-search st str)))) ) (if lst (mapcar \'(lambda(e) (vl-string-trim " " e)) lst)) ) ;;Use ACAD command directly (defun yad_comd() (setvar "cmdecho" 1) (while (/= 0 (getvar "cmdactive")) (command pause)) (setvar "cmdecho" 0) ) ;;yad_Examples of using the comd function;; (if (setq p1 (getpoint "\\nPlease click to get the starting point of the building outline: ")) (progn (setvar "cmdecho" 1) (command "_.pline" p1 "_w" "50" "") (prompt "\\nUse the PLINE command to continue drawing building outlines! ") (yad_comd);;Try what would happen without this function (alert "test ok!") ;;Following code can be added) ) ;;;Improved version: (defun c:wht() ;(CMDLA0) (while t (setq i 0 n 255) (command "erase" "all" "") (repeat n (setq i (1+ i)) (command "color" (itoa i)) (command "POLYGON" (+ i 3) '(0 0) "I" (+ 1 ( * i 5))) (command "Zoom" "E") ) ) ;(CMDLA0) ) (defun c:pb( ) (setvar "cmdecho" 0) (setq dx (getvar "screensize")) (setq kgb (/ (car dx) (cadr dx))) (setq hd (getvar "viewsize")) (setq vcen (getvar "viewctr")) (setq a (list (- (car vcen) ( * hd kgb 0.5)) (- (cadr vcen) (/ hd 2)))) (setq b (list (+ (car a) ( * hd kgb)) (+ (cadr a) hd))) (setq ang 1) (setq pcen vcen) (setq r (/ (abs (- (cadr a) (cadr b)))) 10)) (setq a (list (+ (car a) r) (+ (cadr a) r)) b (list (- (car b) r) (- (cadr b) r))) (setq col 1) (command "color" col) (command "circle" pcen r) (setq obj (entlast)) (while t (command "move" obj "" pcen (polar pcen ang (/ r 50))) (setq pcen (polar pcen ang (/ r 50))) (if (or (&gt; (car pcen) (car b))( < (car pcen)(car a)) (> (cadr pcen) (cadr b))( < (cadr pcen)(cadr a))) (progn (setq pcen0 (polar pcen (+ ang pi) (/ r 50))) (cond ((inters pcen pcen0 a (list (car a) (cadr b)))(setq ang (- pi ang))) ((inters pcen pcen0 b (list (car b) (cadr a)))(setq ang (- pi ang))) ( t (setq ang (- (* 2 pi) ang))) ) (setq col (1+ col)) (if (= 7 col) (setq col 1)) (command "change" obj "" "p" "c" col "") ) ) ) ) (princ "成功调入！ ***键入 pb 运行***") (prin1) (defun c:fg( / dang p1 p2 ang p3 str sname) (setvar "cmdecho" 0) (setvar "osmode" 0) (command "zoom" "w" "0,62" "200,-58") (command "line" "-60,0" "260,0" "") (setq str '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "center") (100 . "AcDbLine") (10 0.0 0.0 0.0) (11 0.0 10.0 0.0) (210 0.0 0.0 1.0))) (entmake str) (setq sname (entlast)) (setq dang (/ pi 180) ang (- (/ pi 2) dang)) (setq p1 (list 0 0) p2 (polar p1 ang 10)) (while t ;(if ( dang 0)(= ang pi)) (setq p3 (polar p1 pi 10) p1 p3 p2 (polar p1 0 10) ang 0)) (setq str (entget sname)) (setq str (subst (cons 10 p1) (assoc 10 str) str)) (setq str (subst (cons 11 p2) (assoc 11 str) str)) (entmod str) (redraw) (setq sname (entlast)) (setq ang (- ang dang)) (setq p2 (polar p1 ang 10)) (if (or (> = 0 (car p2))(