b.lsp

此代码为Lisp语言编写

        (setq svr(getvar "osmode"))
        (setvar "osmode" 0)
	(if (and (> a1 90) (<= a1 270));if1
		(progn
			(setq jd(polar jd (dtr a1) bzc))
			(setq jf lf lf rf rf jf)
			(setq a1(+ a1 180))
			(setq zy 1)
		);end of progn
		(setq zy -1)
	);end of if1
	(if (>= bzc (* w bzg (strlen bzf))) (setq zy0 0) (setq zy0 -1))
	(setq a(dtr a1) b(dtr jj) jdy(polar jd a bzc))
	(cond ;cond0
		  ((= mf 1);mf=1
		   (setq pt1(polar jd (+ a b) bzs))
		   (setq pt2(polar jd (+ a b pi) bzx))
                   (if (/= jj 0)(command "line" pt1 pt2 ""))
		   (setq pt1(polar jd a bzjc))
		   (setq pt2(polar jdy (+ pi a) bzjc))
		   (command "pline" jd "W" 0 bzjk pt1 "w" 0 0 pt2 "W" bzjk 0 jdy "")
		   (setq ptc(polar jd a (/ bzc 2)))
		   (if (= zy0 0) (setq ptc(polar ptc (+ pi2 a) bzjj))
						 (setq ptc(polar ptc (+ pi2 a) (+ bzjj bzs)))
		   );end of if
		   (command "text" "C" ptc bzg a1 bzf)
		   (if (= rf -1);if1
				(progn
					(setq pt1(polar jdy (+ a b) bzs))
					(setq pt2(polar jdy (+ a b pi) bzx))
                                        (if (/= jj 0)(command "line" pt1 pt2 ""))
				)
		   );end of if1
		  );end of mf=1
		  (t   ;t1
		   (cond  ;cond1
				 ((= lf -1)  ;lf=-1
				  (setq pt1(polar jd (+ a b) bzs))
				  (setq pt2(polar jd (+ pi a b) bzx))
                                  (if (/= jj 0)(command "line" pt1 pt2 ""))
				  (setq pt1(polar jd (+ pi a) bzjc))
				  (setq pt2(polar jd (+ pi a) bzjwc))
				  (command "pline" jd "W" 0 bzjk pt1 "W" 0 0 pt2 "")
				  (cond   ;cond2
						((= rf -1) ;rf=-1
						 (setq pt1(polar jdy (+ a b) bzs))
						 (setq pt2(polar jdy (+ pi a b) bzx))
                                                 (if (/= jj 0)(command "line" pt1 pt2 ""))
						 (setq pt1(polar jdy a bzjc))
						 (setq pt2(polar jdy a bzjwc))
						 (command "pline" jdy "W" 0 bzjk pt1 "W" 0 0 pt2 "")
						 (cond    ;cond3
							   ((= zy -1)   ;zy=-1
								(setq ptc(polar jd (+ a pi) bzjc))
								(setq ptc(polar ptc (+ a pi2) bzjj))
								(command "text" "R" ptc bzg a1 bzf)
							   );end of zy=-1
							   ((= zy 1) ;zy=1
								(setq ptc(polar jdy a bzjc))
								(setq ptc(polar ptc (+ a pi2) bzjj))
								(command "text" ptc bzg a1 bzf)
							   );end of zy=1
						 );end of cond3
						) ;end of rf=-1;
						(t   ;t2
						 (setq ptc(polar jd (+ a pi) bzjc ))
						 (setq ptc(polar ptc (+ a pi2) bzjj))
						 (command "text" "R" ptc bzg a1 bzf)
						);end of t2
				  );end of cond2
				 ) ;end of lf=-1;
				 ((= lf 1)  ;lf=1
				  (setq pt1(polar jd (+ a b) bzs))
				  (setq pt2(polar jd (+ a b pi) bzx))
                                  (if (/= jj 0)(command "line" pt1 pt2 ""))
				  (cond ((= rf -1)
						 (setq pt1(polar jdy (+ a b) bzs))
						 (setq pt2(polar jdy (+ a b pi) bzx))
                                                 (if (/= jj 0)(command "line" pt1 pt2 ""))
						 (setq pt1(polar jdy a bzjc))
						 (setq pt2(polar jdy a bzjwc))
						 (command "pline" jdy "W" 0 bzjk pt1 "W" 0 0 pt2 "")
						 (setq ptc(polar jdy a bzjc))
						 (setq ptc(polar ptc (+ pi2 a) bzjj))
						 (command "text" ptc bzg a1 bzf)
						)
						(t ;t3
						 (setq ptc(polar jd a (/ bzc 2)))
						 (if (= zy0 0) (setq ptc(polar ptc (+ pi2 a) bzjj))
									   (setq ptc(polar ptc (+ pi2 a) (+ bzjj bzs)))
						 )
						 (command "text" "C" ptc bzg a1 bzf)
						);end of t3
				  )
				 );end of lf=1;
				 ((= lf 2)  ;lf=2
				  (setq pt1(polar jd (+ a b) bzs))
				  (setq pt2(polar jd (+ a b pi) bzx))
                                  (if (/= jj 0)(command "line" pt1 pt2 ""))
		  (command "donut" 0 BZD jd "")
				  (cond ((= rf -1)  ;cond4
						 (setq pt1(polar jdy (+ a b) bzs))
						 (setq pt2(polar jdy (+ a b pi) bzx))
                                                 (if (/= jj 0)(command "line" pt1 pt2 ""))
						 (setq pt1(polar jdy a bzjc))
						 (setq pt2(polar jdy a bzjwc))
						 (command "pline" jdy "W" 0 bzjk pt1 "W" 0 0 pt2 "")
						 (setq ptc(polar jdy a bzjc))
						 (setq ptc(polar ptc (+ pi2 a) bzjj))
						 (command "text" ptc bzg a1 bzf)
						)
						(t  ;t4
						 (setq ptc(polar jd a (/ bzc 2)))
						 (if (= zy0 0) (setq ptc(polar ptc (+ pi2 a) bzjj))
									   (setq ptc(polar ptc (+ pi2 a) (+ bzg bzjj)))
						 )
						 (command "text" "C" ptc bzg a1 bzf)
						);end of t4
				  ) ;end of cond4
				 ) ;end of lf=2
		   );end of cond1
		  );end of t1
	);end of cond0
        (setvar "osmode" svr)
)
(defun diml(jd bzf bzjd bzqj bl / sl vl dl ni n_a jd1 bzc bzff lf rf)
	(grtext -2 "DIML")
	(cond ((= (type bzf) 'str)
		   (setq sl(stl bzf)
				 vl(sltvl sl (* 0.1 bl))
				 dl(vltdl vl))
		   )
		  ((= (type bzf) 'list)
		   (setq sl (mapcar 'rts bzf) vl (sltvl sl (* 0.1 bl)) DL (VLTDL VL))
		  )
		  (t
		   (setq sl(list (rts bzf)) vl(sltvl sl (* 0.1 bl)) dl(vltdl vl))
		  )
	)
	(setq ni(length sl) n_a 0)(setq sl(mapcar 'sts sl))
	(setq jd1 jd)
	(repeat ni
		(setq bzc(nth n_a vl)
			  bzff(nth n_a sl)
			  lf(nth n_a dl)
			  rf(nth (+ n_a 2) dl)
		)
		(dim0 jd1 bzc bzff bzjd bzqj lf rf)
		(setq jd1(polar jd1 (dtr bzjd) bzc))
		(setq n_a(1+ n_a))
	)
)
(defun dimf(jd bzc bzf bzjd bzqj / sl vl dl ni n_a jd1 bzc bzff lf rf)
		 (grtext -2 "DIMF")
		 (cond ((= (type bzc) 'str)
		 (setq vl(sltvl (stl bzc) 1.0) dl(vltdl vl)))
		 ((= (type bzc) 'list)
		 (setq vl (mapcar 'rtv bzc) dl(vltdl vl)))
		 (t (setq vl (list (eval bzc)) dl(vltdl vl))))
		 (cond ((= (type bzf) 'str) (setq sl(stl bzf)))
		 ((= (type bzf) 'list) (setq sl (mapcar 'rts bzf)))
		 (t (setq sl(list (rts (eval bzf))))))
		 (setq ni(length sl) n_a 0 sl(mapcar 'ss1__a sl))
		 (setq jd1 jd)
		 (repeat ni
		 (setq bzc(nth n_a vl)
		 bzff(nth n_a sl)
		 lf(nth n_a dl)
		 rf(nth (+ n_a 2) dl))
		 (dim0 jd1 bzc bzff bzjd bzqj lf rf)
		 (setq jd1(polar jd1 (dtr bzjd) bzc))
		 (setq n_a(1+ n_a))))
(defun dimb(jd1 jd2 bzf bzqj / a1 bzc )
		 (grtext -2 "DIMB")
		 (setq a1(angle jd1 jd2) a1(rtd a1))
		 (setq bzc(distance jd2 jd1))
		 (dim0 jd1 bzc (rts bzf) a1 bzqj -1 -1))
(defun bre(p1 p2 p3 p4 enm l1_a / pp1 pp2 pp3 f t1 t2 n_a)
		 (setq n_a 0 f 1)
		 (while (and (< n_a (- (length l1_a) 3)) f)
		 (setq pp1(nth n_a l1_a))
		 (setq pp2(nth (+ n_a 1) l1_a))
		 (setq t1(or (inters p1 p2 pp1 pp2) (inters p2 p3 pp1 pp2)
		 (inters p3 p4 pp1 pp2) (inters p4 p1 pp1 pp2)))
		 (WHILE (and (< n_a (- (LENGTH l1_a) 3)) t1)
		 (setq pp1(nth (+ n_a 1) l1_a))
		 (setq pp3(nth (+ n_a 2) l1_a))
		 (setq t2(or (inters p1 p2 pp3 pp1) (inters p2 p3 pp3 pp1)
		 (inters p3 p4 pp3 pp1) (inters p4 p1 pp3 pp1)))
		 (setq n_a(1+ n_a)))
		 (if (and t1 t2)
		 (progn(command "break" enm pp2 "@")
		 (setq f nil)))
		 (setq n_a (1+ n_a)))f)
(defun inta(p1 p2 p3 p4 / pp tt d1 d2 d12)
		 (setq pp(inters p1 p2 p3 p4 nil) tt nil)
		 (if pp
		 (progn
		 (setq d1(distance pp p1) d2(distance pp p2) d12(distance p1 p2))
		 (if (<= (abs (- (+ d1 d2) d12)) 0.00001)
		 (setq tt pp)))))
(defun tr1(p1 p2 p3 p4 pt1 pt2 enm / pp pp1 pp2 tt)
		(if (and (setq pp(inters p1 p2 pt1 pt2)) (/= pp pt1) (/= pp pt2))
		(progn
		(setq pp1 pp)
		(if (setq pp(inta p2 p3 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p3 p4 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p4 p1 pt1 pt2)) (setq pp2 pp))))
		(if (and (setq pp(inters p2 p3 pt1 pt2)) (/= pp pt1) (/= pp pt2))
		(progn
		(setq pp1 pp)
		(if (setq pp(inta p3 p4 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p4 p1 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p1 p2 pt1 pt2)) (setq pp2 pp))))
		(if (and (setq pp(inters p3 p4 pt1 pt2)) (/= pp pt1) (/= pp pt2))
		(progn
		(setq pp1 pp)
		(if (setq pp(inta p4 p1 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p1 p2 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p2 p3 pt1 pt2)) (setq pp2 pp))))
		(if (and (setq pp(inters p4 p1 pt1 pt2)) (/= pp pt1) (/= pp pt2))
		(progn
		(setq pp1 pp)
		(if (setq pp(inta p1 p2 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p2 p3 pt1 pt2)) (setq pp2 pp))
		(if (setq pp(inta p3 p4 pt1 pt2)) (setq pp2 pp))))
		(if (and (entget enm) pp1 pp2 pt1 pt2 (or
		(< (max (distance pp1 pt1) (distance pp1 pt2))
		(- (distance pt1 pt2) 0.00001))
		(< (max (distance pp2 pt1) (distance pp2 pt2))
		(- (distance pt1 pt2) 0.00001))))
		(setq tt 1))
		(if tt (command "break" enm pp1 pp2)))
(defun gpver(entnme / ee)
;返回pline实体或line实体entnme的各顶点坐标构成的表
    (setq ee(entget entnme))
	(cond
		(
			(= (cdr (assoc 0 ee)) "LINE")
            (gpver_line entnme)
		)
		(
			(= (cdr (assoc 0 ee)) "POLYLINE")
            (gpver_pline entnme)
		)
		(
			(= (cdr (assoc 0 ee)) "LWPOLYLINE")
            (gpver_lwp entnme)
		)
		(t
			nil
        )
	)
 )
(defun gpver_pline(entnme / subent verlst vertex eep)
;返回pline实体entnme的各顶点坐标构成的表
	(setq subent(entnext entnme) eep(entget subent))
       (setq verlst nil vertex 1)
	   (while (= (cdr (assoc 0 eep)) "VERTEX")
	      (setq vertex (cdr (assoc 10 eep)))
	      (setq verlst(append verlst (list vertex)))
		  (setq subent(entnext subent) eep(entget subent))
       )
       verlst
)
(defun gpver_lwp(entnme / verlst vertex eep ii)
;返回pline实体entnme的各顶点坐标构成的表
	   (setq eep(entget entnme ) verlst nil ii 0)
       (setq vertex(member (assoc 10 eep) eep))
	   (while (= (car (nth (* ii 4) vertex)) 10)
		  (setq verlst(append verlst (list (cdr (nth (* ii 4) vertex)))))
		  (setq ii(+ 1 ii))
       )
       verlst
)
(defun gpver_line(entnme / ee)
;返回line实体entnme的两点坐标构成的表
	(setq ee(entget entnme))
	(list (cdr (assoc 10 ee))(cdr (assoc 11 ee)))
 )
(defun trlp(p0 a b al / ver__a at ab p1 p2 p3 p4 pc1 pc2 ss1 n1_a n2 len nt l1_a enm)
		 (grtext -2 "TRLP")
		 (SETQ VER__A (read (substr (ver) 17)))
		 (if (> ver__a 8.0) (setq p0 (trans p0 1 0)))
		 (if (> ver__a 8.0) (command "ucs" "D" "ucs__a" "ucs" "s" "ucs__a" "ucs" "W"))
		 (setq at(dtr al) ab(/ a 2.0))
		 (setq p1(polar p0 (+ pi at) ab) p2(polar p1 at a)
		 p3(polar p2 (+ pi2 at) b) p4(polar p3 (+ pi at) a))
		 (GRDRAW P1 P2 1)(GRDRAW P2 P3 1)(GRDRAW P3 P4 1)(GRDRAW P4 P1 1)
		 (setq pc1(list (min (car p1) (car p2) (car p3) (car p4))
		  (min (cadr p1) (cadr p2) (cadr p3) (cadr p4)))
		 pc2(list (max (car p1) (car p2) (car p3) (car p4))
		  (max (cadr p1) (cadr p2) (cadr p3) (cadr p4))))
		 (setq nt -1 len 0)
		 (while (< nt len)
		 (setq nt 0)
		 (setq ss1(ssget "C" pc1 pc2))
		 (if ss1 (setq len(sslength ss1)))
		 (setq n1_a 0)
		 (repeat len
		 (setq enm(ssname ss1 n1_a))
		 (if (= (cdr (assoc 0 (entget enm))) "POLYLINE")
		 (progn(setq l1_a(gpver enm))
		 (if (> (length l1_a) 3) (if (bre p1 p2 p3 p4 enm l1_a)
		  (setq nt (1+ nt))) (setq nt (1+ nt)))
		 ) (setq nt(1+ nt)))
		 (setq n1_a(1+ n1_a))))
		 (setq n1_a 0)
		 (repeat len
		 (setq enm(ssname ss1 n1_a))
		 (if (= (cdr (assoc 0 (entget enm))) "LINE")
		 (tr1 p1 p2 p3 p4 (cdr (assoc 10 (entget enm)))
		  (cdr (assoc 11 (entget enm))) enm))
		 (if (= (cdr (assoc 0 (entget enm))) "POLYLINE")
		 (progn
		 (setq l1_a(gpver enm) n2 0 pc1 1 pc2 1)
		 (while (and (< n2 (length l1_a)) pc1 pc2)
		 (setq pc1(nth n2 l1_a))
		 (setq pc2(nth (+ 1 n2) l1_a))
		 (if (and ENM pc1 pc2) (tr1 p1 p2 p3 p4 pc1 pc2 enm))
		 (setq n2(1+ n2)))))
		 (setq n1_a(1+ n1_a)))
		 (if (> ver__a 8.0) (command "ucs" "r" "ucs__a" "ucs" "D" "ucs__a")))
(defun ds(jd ll ww / bl nn pp pc tt)
	(grtext -2 "DS")
	(cond((= ww 99)
	      (cond((= (type ll) 'str) (setq bl(stl ll)))
		   ((= (type ll) 'list) (setq bl ll))
		   (t (setq bl(list (rts ll))))
	      )
	     )
	     ((= (type ll) 'list) (setq bl ll))
	     ((= (type ll) 'str) (setq bl (sltvl (stl ll) 1)))
	     (t (setq bl(list (rtv ll))))
	)
	(setq nn 0)
	(repeat (length bl)
	(setq pp(polar jd pi3 (* nn bg_a)))
		(if (< ww 0) (setq tt(rtos (nth nn bl) 2 0))
	    (if (= ww 99) (setq tt(nth nn bl))
		(setq tt(rtos (nth nn bl) 2 ww))
	    )
	)
	(if (< ww 0)
	    (gjdj pp (nth nn bl) 0)
	    (command "text" "M" pp bzg 0 tt)
		)
		(setq nn(1+ nn))
	)
)
(DEFUN DELS(s / ss)
		 (grtext -2 "DELS")
		 (setq ss(ssget "X" (list (cons 0 s))))
		 (if ss (command "erase" ss "")))
(DEFUN C:DEL1( / LA ss)
		 (grtext -2 "DEL1")
         (SETQ LA(GETSTRING "\n输入删除物体所在图层:"))
		 (setq ss(ssget "X" (list (cons 8 la))))
	 (if ss (command "erase" ss)))
(defun diarc(jd al1 al2 / dtal tf aj a1 a2 a0 p1 p2 p3 p4 pc)
		 (setq dtal(- al2 al1) dtal(bj__a dtal))
		 (if (< (* r_darc (dtr dtal)) (* 2.2 bzjc))
		 (setq tf nil) (setq tf t))
		 (setq a1(dtr al1) a2(dtr al2) aj(/ bzjc 1.0 r_darc)
				 p1(polar jd a1 r_darc) p2(polar jd (+ aj a1) r_darc)
				 p3(polar jd (- a2 aj) r_darc) p4(polar jd a2 r_darc)
				 a0(+ a1 (/ (dtr dtal) 2.0))
				 pc(polar jd a0 (* r_darc 1.2)))
		 (if tf (command "pline" p1 "W" 0 bzjk "A" "CE" jd p2
							  "W" 0 0 "ce" jd p3 "W" bzjk 0 "ce" jd p4 "")