Lisp vẽ mặt cắt từ bình đồ:

Lệnh VMC.

 

;; Bien toan cuc deltaH
(defun c:vmc ( / sel)
 (defun luuos ()
   (setq
     HOANH_OSMODE   (getvar...
>>

Lisp vẽ mặt cắt từ bình đồ:

Lệnh VMC.

 

;; Bien toan cuc deltaH
(defun c:vmc ( / sel)
 (defun luuos ()
   (setq
     HOANH_OSMODE   (getvar "OSMODE")
     HOANH_AUTOSNAP (getvar "AUTOSNAP")
   )
 )
 (defun traos ()
   (if	HOANH_OSMODE
     (setvar "OSMODE" HOANH_OSMODE)
   )
   (if	HOANH_AUTOSNAP
     (setvar "AUTOSNAP" HOANH_AUTOSNAP)
   )
 )
 (defun GiaoDT	(ent1 ent2)
   (setq ob1 (vlax-ename->vla-object ent1)
  ob2 (vlax-ename->vla-object ent2)
   )
   (setq g (vlax-variant-value
      (vla-IntersectWith ob1 ob2 acExtendNone)
    )
   )
   (if	(/= (vlax-safearray-get-u-bound g 1) -1)
     (setq g (vlax-safearray->list g))
     (setq g nil)
   )
   (if	g
     (progn
(setq kq nil
      sd (fix (/ (length g) 3))
)
(repeat	sd
  (setq	kq (append kq (list (list (car g) (cadr g) (caddr g))))
	g  (cdddr g)
  )
)
kq
     )
     nil
   )
 )
 (defun NhapdeltaH( / tmp)    
   (while (not tmp)
     (setq tmp (getdist "\nVao khoang cach deltaH: "))
     (if (not tmp)
(setq tmp deltaH)
     )
   )
   (setq deltaH tmp)
 )
 ;;;---------------------- Main --------------------------------
 (princ "\nVMC © CADViet.com")  
 (if (not deltaH)
   (NhapdeltaH)
 )  
 (while (not sel)
   (setq	sel  (entsel "\nVao line mat cat (hoac nhan Enter de nhap deltaH): ")
entl (car sel)
   )
   (if (not sel)
     (NhapdeltaH)
   )
 )
 (if (= "LINE" (cdr (assoc 0 (entget entl))))
   (progn
     (setq
p  (cadr sel)
tt (entget entl)
p1 (cdr (assoc 10 tt))
p2 (cdr (assoc 11 tt))
     )
     (if (> (distance p p1)
     (distance p p2)
  )
(setq p	 p1
      p1 p2
      p2 p
)
     )
     (luuos)
     (setvar "osmode" 0)
     (command ".zoom" p1 p2)
     (setq
sspl  (ssget "F"
	     (LIST P1 P2)
	     '((-4 . "<OR")
	       (0 . "LWPOLYLINE")
	       (0 . "SPLINE")
	       (-4 . "OR>")
	      )
      )
tappl (ss2ent sspl)
goc   (+ (angle p1 p2) (/ pi 2.0))
index 0
tappn nil
     )
     (command ".zoom" "p")
     (foreach entpl tappl
(if (setq tmp (giaodt entpl entl))
  (setq
    p	  (car tmp)
    pn	  (polar p goc (* deltaH index))
    index (1+ index)
    tappn (append tappn (list pn))
  )
)
     )
     (command ".pline")
     (foreach pn tappn
(command pn)
     )
     (command "")
     (traos)
   )
 )
 (princ)
)

(vl-load-com)
(princ "\nVe mat cat tu binh do © CADViet.com 2007")
(princ "\nDung lenh VMC de bat dau!")
(princ)

 

Hướng dẫn sử dụng:

- Lệnh VMC vẽ mặt cắt của địa hình theo vết cắt cho trước. Địa hình được mô tả bằng các đối tượng pline hay spline có z=0 là đường đồng mức. Vết cắt là một line.

- Khi sử dụng lệnh lần đầu tiên, chương trình sẽ yêu cầu nhập deltaH. Các lần sau, chương trình sẽ không yêu cầu nhập lại deltaH. Muốn hiệu chỉnh giá trị deltaH, bạn nhấn enter khi chương trình hỏi vết cắt.

- Mỗi lần sử dụng, chương trình sẽ yêu cầu chọn 1 line làm vết cắt. Chương trình sẽ vẽ mặt cắt theo vết cắt và deltaH đã chỉ định.

 

Cảm ơn anh Hoành đã share với dân trắc địa, nhưng tôi sử dụng gặp lỗi như sau:

 

Command: vmc

VMC © CADViet.com

Vao line mat cat (hoac nhan Enter de nhap deltaH): .zoom

Specify corner of window, enter a scale factor (nX or nXP), or

<real time>:

Specify opposite corner:

Command: ; error: no function definition: SS2ENT

 

mong anh hướng dẫn. Thanks

<<

 

Chắc là cộng dim ra con số tổng chứ hả? Code này chỉ cho ra kết quả tại dòng command line

>>

 

Chắc là cộng dim ra con số tổng chứ hả? Code này chỉ cho ra kết quả tại dòng command line

(defun c:ccd(/ gtt dt sdt ent id)
  (setq dt (ssget '((0 . "DIMENSION")))
	sdt (sslength dt)
	id 0
	gtt 0
	)
  (repeat sdt
	(setq
  	ent (ssname dt id)
      id (1+ id)
  	gtt (+ gtt (gt1 ent) )
  	)
	)
  (princ gtt)
  (princ)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gt1(ent / so)
	(if (wcmatch(cdr(assoc 1 (entget ent)))"")
  	(setq so (cdr(assoc 42 (entget ent))))
  	(setq so (atof(cdr(assoc 1 (entget ent)))))
  	)
	)

Cái này hay nhưng có thể thêm chức năng xuất kết quả thay cho 1 text có sẵn không bạn? Nếu sửa dc thì cho mình xin lisp đó nhé. Thanks

Trên cái Lisp mà bạn lp_hai đã viết, Tue_NV thêm thắt chút ít .

Xuất hiện hộp thoại -> Bạn nhấn Copy -> Paste vào ô trong...

>>

Trên cái Lisp mà bạn lp_hai đã viết, Tue_NV thêm thắt chút ít .

Xuất hiện hộp thoại -> Bạn nhấn Copy -> Paste vào ô trong Excel

(defun c:ccd(/ gtt dt sdt ent id str)
 (setq dt (ssget '((0 . "DIMENSION")))
sdt (sslength dt)
id 0
gtt 0
str "="
)
 (repeat sdt
(setq
  ent (ssname dt id)
     id (1+ id)
  gtt (+ gtt (gt1 ent) )
str (strcat str  (Rtos (gt1 ent)) "+")
  )
)
(Lisped (substr str 1 (1- (strlen str))))
 (princ gtt)
 (princ)
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gt1(ent / so)
(if (wcmatch(cdr(assoc 1 (entget ent)))"")
  (setq so (cdr(assoc 42 (entget ent))))
  (setq so (atof(cdr(assoc 1 (entget ent)))))
  )
)

Ok. đúng rồi.

Cảm ơn mọi người rất nhiều...

<<

1) Dùng lệnh Cad:

 

- Gõ lệnh bo (boundary), pick vào vùng cần tính -> 1 pline kín được tạo thành.

- Select nó, gõ lệnh mo...

>>

1) Dùng lệnh Cad:

 

- Gõ lệnh bo (boundary), pick vào vùng cần tính -> 1 pline kín được tạo thành.

- Select nó, gõ lệnh mo sẽ thấy diện tích. Nếu không cần đến nó nữa thì bấm del.

 

2) Dùng lisp:

 

Gõ lệnh are, toàn bộ thao tác trên được thực hiện tự động.

 

(defun c:gb(/ p ss S frome cur toe tt)
(setq p (getpoint "\n Pick 1 diem vao mien trong hinh kin :") 
ss (ssadd) S 0)
(while p
(setq frome (entlast))
(command ".boundary" p "")
(setq toe (entlast));; 
(setq cur frome
)
   (while (not (eq cur toe))
(setq cur (entnext cur)
	ss (ssadd cur ss))
(command "area" "S" "O" ss "" "")
(setq tt (getvar "area"))
(setq S (+ S tt))
    )
 (command "area" "A" "O" "L" "" "")
 (setq tt (getvar "area"))
 (setq S (+ S (* tt 2))) 
(sssetfirst ss ss)
(setq p (getpoint "\n Pick 1 diem vao mien trong hinh kin :"))

)
(if (> (sslength ss) 0)
(alert (strcat "Area = " (rtos S 2 2)))
(alert "\n Ban chua Pick vao mien kin nao ca ")
)
(command "erase" ss "")
(Princ)
)

@ ndn386 : Bạn muốn thêm 3 chữ số thập phân thì thay dòng này

(alert (strcat "Area = " (rtos S 2 2)))

thành dòng :

(alert (strcat "Area = " (rtos S 2 3)))

thay số 2 thành số 3 : chính là chữ số thập phân đó bạn

Chốt lại vấn đề đã có rất rất nhiều nhiều lisp trên diễn đàn, chỉ vì không sử dụng chức năng tìm kiếm, mà một số câu nói không hay đã tuôn ra… :D :D :wacko: :wacko: :wacko: :wacko: :wacko: :wacko: :undecided: :blink: :blink: :wacko: :D

<<

Lisp nối Arc, Line, Polyline, Lwpolyline của Jimmy Bergmark. Chấp nhận giữa các đối tượng có khoảng hở (fuzz).

>>

Lisp nối Arc, Line, Polyline, Lwpolyline của Jimmy Bergmark. Chấp nhận giữa các đối tượng có khoảng hở (fuzz).

(defun c:jf () (c:pljoinfuzz))
(defun c:pljoinfuzz (/ ss1 entLine objType oldcmdecho oldpeditaccept fuzz okObjects)
 (setq oldcmdecho (getvar "cmdecho"))
 (setq oldpeditaccept (getvar "PEDITACCEPT"))
 (setvar "cmdecho" 0)
 (setq A2k4 (>= (substr (getvar "ACADVER") 1 2) "16"))
 (if A2k4 (setvar "PEDITACCEPT" 0))
 (setq okObjects '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE")))
 (princ "\nSelect object to join: ")
 (setq ss1 (ssget okObjects))
 (setq fuzz (getdist "\nFuzz distance <0>: "))
 (if (= fuzz nil) (setq fuzz 0))
 (if (/= ss1 nil)
 	(progn
(setq objType (cdr (assoc 0 (entget (setq entLine (ssname ss1 0))))))
(if (= (sslength ss1) 1) (setq ss1 (ssget "X" okObjects)))
(if (member objType '("LINE" "ARC"))
 	(command "_.pedit" "_M" ss1 "" "_Y" "_J" "_J" "_B" fuzz "")
 	(command "_.pedit" "_M" ss1 "" "_J" "_J" "_B" fuzz ""))))
 (setvar "cmdecho" oldcmdecho)
 (if A2k4 (setvar "PEDITACCEPT" oldpeditaccept))
 (princ))

lisp này là chỉnh sửa của lệnh pedit, nối arc thì chuyển thành pline. mình muốn khi nối nó giữ luôn là arc, tạo thành cung tròn trơn như ban đầu.

<<

Bình thường mình k dùng lisp để rải thép,toàn copy thủ công thôi^^ .

Bạn thử dùng cái này xem sao nhé

 

 

>>

Bình thường mình k dùng lisp để rải thép,toàn copy thủ công thôi^^ .

Bạn thử dùng cái này xem sao nhé

 

 

(Defun c:Tmu (/ d1 d2 d3 d4);(THEPSAN)
(setvar "angbase" 0)
;(setvar "clayer" ....)
(command "ortho" "on")
(setq d1 (getpoint "\nDiem thu nhat:"))
(setq d2 (getpoint d1"\nDiem thu hai:"))
(setq goc (angle d1 d2))
(setvar "osmode" 0)
(setq d3 (POLAR d1 (+ goc (/ pi 2)) 3))
(setq d4 (polar d3 goc (distance d1 d2)))
(Command "_.pline" d1 d3 d4 d2 "" )
(setvar "osmode" 641)
(princ)
)

e có sd lisp của bác nhưng doạn moc xuống ngắn quá..bác sửa lại cho to lên đc k ạ

<<

Download lisp

Filename: 405274_tmu.lsp

Bạn đã vẽ CAD lâu chưa :undecided:

Cách làm ngắn gọn là như thế này nhé.Đầu tiên bạn down file lisp này về để ở 1 chỗ nào đó...

>>

Bạn đã vẽ CAD lâu chưa :undecided:

Cách làm ngắn gọn là như thế này nhé.Đầu tiên bạn down file lisp này về để ở 1 chỗ nào đó gọn gàng và dễ thấy

Sau đó dùng lệnh appload ( thông thường lệnh tắt là ap),chọn đến file bạn vừa down về -> nhấn LOAD

OK.Vậy là bạn có thể sử dụng 2 lệnh mới do đoạn LISP trên quy định :

1 là CD dùng để cắt thằng hàng phần kéo dài dim

2 là GD dùng để sắp xếp điểm đặt dim

2 lệnh này quy định trong nội dung của file lisp ở dòng defun c:cd

và defun c:gd,nếu thấy k thích dùng là cd,gd thì bạn có thể thay chữ cd,gd thành a bê cê đê e j đó,miễn là k phải tiếng việt có dấu và không nên trùng với các lệnh khác.

Nếu muốn tất cả các bản vẽ đều có thể sử dụng mà cần load lại,thì sau khi dùng lệnh ap,bạn kick vào nút Contens ở bên dưới chữ Starup Suite và hình cái cặp,rồi chọn Add,và lại chọn đến file này

(defun ctd_err (s)
   (if(/= s "Function cancelled")
      (princ (strcat "\nError: " s)) )(setq *error* old_err)(princ)
)
(defun C:GD (/ dim_ch ll_ d13_ d14_ d4_ d2_ point_cat old_osm  d10_n cat_h ang_h
                ang_n dis_1 ang_g ang_d dim_l dim_new dis_h old_ang)
(setq old_err *error* *error* ctd_err)
(setvar "Cmdecho" 0)
(setq old_osm(getvar "Osmode") old_ang(getvar "Angdir"))
(setvar "Angdir" 0); (setvar "Osmode" 0)
(prompt "\nChon Dim <Aligned-Liner-Hor-Ver> dinh giong hang.")
(if(and(setq dim_ch(ssget '((0 . "DIMENSION"))))
      (setq point_cat(getpoint "\nDiem moc giong hang <New>: ")) ) 
  (progn
    (setq ll_ 0 tol_(sslength dim_ch) total 0.0)
    (while (< ll_ tol_)
(setq d2_(ssname dim_ch ll_) d3_(entget d2_) d4_(cdr(assoc 1 d3_)) )
       (prompt "\nDiem giong moi")
(if(and d3_ d4_)
	   (setq d13_(cdr(assoc 13 d3_))  
                d10_(cdr(assoc 10 d3_))  
         d14_(cdr(assoc 14 d3_))  
                ang_n(angle d10_ d13_)
                dis_1(distance d10_ d13_)
                ang_g(angle d10_ d14_)
                ang_d(- ang_g (dtr 90)) ) ;setq
)
       (if (and d3_ point_cat)
           (progn 
              (setq dis_h(distance d10_ point_cat)
                    ang_h(angle d10_ point_cat)
                    cat_h(* (sin (- ang_h ang_d)) dis_h)
                    d10_n(polar d10_ ang_g cat_h) )
              (if (and d10_ d3_ d10_n)
                  (progn
                    (setq d3_(subst (cons '10 d10_n) (cons '10 d10_) d3_) )
                    (entmod d3_)(prompt "..... OK !")
                  ) (princ "\n..... Khong thuc hien !")
              )
           )
       )
       (setq ll_(+ ll_ 1))
    );while
  )
)
(setvar "Osmode" old_osm)(setvar "Angdir" old_ang)
(setq *error* old_err)
(princ)
)
;;;;;;;; Cat duong giong cac loai Dim (Align - Liner - Hor - Ver)
(defun C:cd (/ dim_ch ll_ d13_ d14_ d4_ d2_ point_cat old_osm dm_13 d10_1 cat_h ang_h
                ang_n dis_1 ang_g ang_d dim_l dim_new dm_14 dis_h old_ang)
(setq old_err *error* *error* ctd_err)
(setvar "Cmdecho" 0)
(setq old_osm(getvar "Osmode") old_ang(getvar "Angdir"))
(setvar "Angdir" 0) ;(setvar "Osmode" 0)
(prompt "\nChon Dim <Aligned-Liner-Hor-Ver> dinh cat.")
(if(and(setq dim_ch(ssget '((0 . "DIMENSION"))))
      (setq point_cat(getpoint "\nDiem moc cat duong giong <New>: ")) ) 
  (progn
    (setq ll_ 0 tol_(sslength dim_ch) total 0.0)
    (while (< ll_ tol_)
(setq d2_(ssname dim_ch ll_) d3_(entget d2_) d4_(cdr(assoc 1 d3_)) )
       (prompt "\nDiem giong moi")
(if(and d3_ d4_)
	   (setq d13_(cdr(assoc 13 d3_))  ;Dim 2 
                d10_(cdr(assoc 10 d3_))  ;Dim Chuan
         d14_(cdr(assoc 14 d3_))  ;Dim 1
                ang_n(angle d10_ d13_)
                dis_1(distance d10_ d13_)
                ang_g(angle d10_ d14_)
                ang_d(- ang_g (dtr 90))
                dim_l(* (cos (- ang_n ang_d)) dis_1) );setq
)
       (if (and dim_l point_cat)
           (progn 
              (setq dis_h(distance d10_ point_cat)
                    ang_h(angle d10_ point_cat)
                    cat_h(* (sin (- ang_h ang_d)) dis_h)
                    dm_14(polar d10_ ang_g cat_h)	;New point2
                    d10_1(polar d10_ ang_d dim_l)
                    dm_13(polar d10_1 ang_g cat_h) )	;New point 1
              (if (and dm_13 dm_14 d14_ d13_ d3_)
                  (progn
                    (setq d3_(subst (cons '13 dm_13) (cons '13 d13_) d3_)
                          d3_(subst (cons '14 dm_14) (cons '14 d14_) d3_))
                    (entmod d3_)(prompt "..... OK !")
                  ) (princ "\n..... Khong thuc hien !")
              )
           )
       )
       (setq ll_(+ ll_ 1))
    );while
  )
)
(setvar "Osmode" old_osm)(setvar "Angdir" old_ang)
(setq *error* old_err)
(princ)
)

 

p/s :nếu bạn là dân vẽ kỹ thuật, bạn nên tìm hiểu sơ qua về lisp,chí ít là cách sử dụng :leluoi: CHúc bạn thành công

 

sau khi load lisp rồi.máy thông báo:

Chon Dim <Aligned-Liner-Hor-Ver> dinh cat.

select object thì mình chọn đường kích thước định cắt rồi enter

máy thông bao:điểm mốc cắt đường gióng mình nhập 200 sa k thấy thay đổi gì nhỉ

<<

~

 

Bạn dùng lisp của bác Thiệp dưới đây, sau khi bắt đối tượng xong bạn muốn move, copy hay xóa thì tùy...

>>

~

 

 

Bạn dùng lisp của bác Thiệp dưới đây, sau khi bắt đối tượng xong bạn muốn move, copy hay xóa thì tùy bạn.

 
(defun c:erC (/ sc cur p0 P1 L1 d L n ssgDEL glength)
  (princ "\nFree lisp from www.cadviet.com")
  (command "undo" "be")
  (setvar "osmode" 0)
  (setq sc 2009
cur (car (entsel "\nchon duong: "))
glength (lambda (e) (command ".lengthen" e "") (getvar "perimeter"))
d (/ (glength cur) sc)
l1 0.0
p0 (vlax-curve-getStartPoint cur)
L (list p0)
  )
  (redraw cur 4)
  (repeat sc
    (setq l1 (+ l1 d)
 p1 (vlax-curve-getPointAtDist cur l1)
    )
    (setq L (append L (List p1)))
  )
  (setq ssgDEL (ssget "WP" L))  
  (command "undo" "end")
  (princ  "\nChuc cac ban may man va thanh cong - Thiep 0918841230" )
  (sssetfirst nil ssgDel)
  (princ)
)
(vl-load-com)

mình chạy cái này rồi muốn xóa thì lại xóa mất dường bao. bác nào biết giúp tui với

<<

Download lisp

Filename: 362965_erc.lsp

 

Đây!

(vl-load-com)
(defun AddObjectsToBlock (ss blk / doc objblk objlst pt p0)
 (setq doc...
>>

 

Đây!

(vl-load-com)
(defun AddObjectsToBlock (ss blk / doc objblk objlst pt p0)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) ;  (setq docs (vla-get-Documents (vlax-get-acad-object))
  objlst (SS->Objlist ss)
  objblk (vlax-ename->vla-object blk)
  pt (vlax-variant-value (vla-get-InsertionPoint objblk))
  p0 (vlax-3d-point '(0 0 0)))
 (foreach obj objlst (vla-Move obj pt p0))
 (vla-CopyObjects doc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length objlst)))) objlst))
  (vla-Item (vla-get-Blocks doc) (vla-get-Name objblk))) ;ten block, VD "Block_A"
 (foreach obj objlst (vla-Delete obj))
 (vla-Regen doc acAllViewports))
(defun SS->Objlist (ss / i lst)
 (repeat (setq i (sslength ss))
  (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))
;----- Test 
(defun C:AOB( / ss blk)
 (princ "\nChon cac doi tuong can add... ")
 (setq ss (ssget))
 (setq blk (car (entsel "\nChon Block: ")))
 (AddObjectsToBlock ss blk))
(defun C:XOA( / ent)
 (setq ent (car (nentsel "\nChon doi tuong can xoa: ")))
 (DeleteObjectFromBlock ent))
(defun DeleteObjectFromBlock (ent / doc blk)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
   ent (vlax-ename->vla-object ent)
   blk (vla-ObjectIdToObject doc (vla-get-OwnerID ent)))
  (vla-Delete ent)
  (vla-Regen doc acAllViewports)
  (vla-get-Count blk))

Nhờ anh sửa giúp lisp này thành move đối tượng ra khỏi block tại vị trí của nó luôn với nhé! Thanks anh!

<<

Download lisp

Filename: 378001_aob_xoa.lsp

(defun C:CD()
 (sssetfirst nil (ssget "X" '((0 . "DIMENSION,LEADER")))))

cám ơn bác,...

(defun C:CD()
 (sssetfirst nil (ssget "X" '((0 . "DIMENSION,LEADER")))))

cám ơn bác, nhanh và đơn giản quá nhỉ. 

sax lạ vậy bạn tải lại bản này xem ngắn gọn hơn xíu chắc ko lỗi ^^

;========LISP TAO VIEWPORT TREN LAYOUT...
>>

sax lạ vậy bạn tải lại bản này xem ngắn gọn hơn xíu chắc ko lỗi ^^

;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;===============REV3=====================
(defun C:mtl(/ taphop soluong ten khung tyle oldos i lst X index)
 (command "UNDO" "BE")
 (setq oldos (getvar "osmode"))
 (setvar "OSMODE" 0)
 (setq taphop(ssget))
  (setq Tyle (getreal (strcat "\n Ty le 1/ <1000>: ")))
 (if (= Tyle nil) (setq Tyle 1000))
 (setq soluong (sslength taphop))
 (setq index 0)
 (setq i 0)
 (setq ten (getstring "\n Nhap ten layout:"))
 (command "layout" "N" ten)
 (command "LAYOUT" "S" ten)
 (command "ERASE" "ALL" "")
 (command "MODEL")
 (setq X 0)
 (command "ZOOM" "E")
 (while (< index soluong)
(setq i(1+ i))
(setq khung(ssname taphop index))
(setq lst(acet-geom-vertex-list khung))
(command "COPYCLIP" khung "")
(command "LAYOUT" "S" ten)
(command "PASTECLIP" (list X 0))
(command "SCALE" (entlast) "" (list X 0) (/ 1000 tyle))
(command "MVIEW" "O" (entlast))
(command "MSPACE")
(command "ZOOM" (nth 0 lst) (nth 2 lst))
(command "PSPACE")
(command "Mview" "L" "on" (entlast) "")
(setq X(+ X 50 (/ (abs(- (car (nth 2 lst)) (car (nth 0 lst)))) (/ tyle 1000))))
(command "ZOOM" "W" (list 0 0) (list (+ X 100) 0))
(setq index (+ index 1))
)
 (command "MODEL")
 (command "UNDO" "END")
 (setvar "OSMODE" oldos)
 (princ)
 )

Hay quá Bạn ơi. Bạn Thật siêu sao. Cảm ơn Bạn Rất rất nhiều. trên forum mình vãn còn một yêu cầu viết lisp ghi chú điểm. bạn xem giúp mình với.

<<

-Lisp trên chỉ thay đổi màu của layer chứa đối tượng bạn chọn chứ ko phải "hết tất cả layer về cùng một màu".

-Bạn...

>>

-Lisp trên chỉ thay đổi màu của layer chứa đối tượng bạn chọn chứ ko phải "hết tất cả layer về cùng một màu".

-Bạn muốn "những đối tượng mình chọn mới thay đổi thành màu khác" nghĩa là thay màu của đối tượng ko còn là bylayer nửa phải ko?

*Nếu vậy thì dùng này:

(defun c:dm (/ m ss)
(command "undo" "be")
 (princ "\nChon doi tuong muon doi mau:")
 (setq ss (ssget))
 (princ "\nChon mau muon doi :")(setq m (acad_colordlg 7))
(command "change" ss "" "P" "c" m "")
(command "undo" "end")
(setvar "MODEMACRO" "**KTS_DUY**")
(princ)
)

 

Tôi đã xoá các bài của kexu và thanhdatkts đề nghị tập trung vào chuyên môn.

@thanhdatkts: đề nghị chồng cho tôi 1 dấu + nếu không tôi chồng cho bạn 1 dấu trừ đấy!

Lisp này dùng rất là hay và tiện dùng.

Bác có thể phát triên lisp này thành một cái tiện hơn nữa. Ví dụ như chỉ cần load lisp này lên sau đó chọn đối tượng=>bấm phím 1, màu đối tượng đó là màu 1...255.

Chắc chắn là bác làm được!

P/S: Sửa lại một chút: sau khi gõ lệnh đổi màu (VD: dm) sau đó chọn đối tượng và bấm phím 1...225 là đối tượng đó đổi màu theo chứ không cần hiện lên cái bảng chọn màu như trong lisp đó nữa.

<<

Hihi ! Em mới kiếm đc cái game trên Autocad ! Mời các bác giải trí nhé :

Lệnh: Banb

;-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
(defun c:banb () (c:troy))
(defun c:Troy (/ Colors$ Loop Option$ Settings$)
 (initget "Intro Clear Settings Play")
 (if (not (setq Option$ (getkword "\nTroy options :...
>>

Hihi ! Em mới kiếm đc cái game trên Autocad ! Mời các bác giải trí nhé :

Lệnh: Banb

;-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
(defun c:banb () (c:troy))
(defun c:Troy (/ Colors$ Loop Option$ Settings$)
 (initget "Intro Clear Settings Play")
 (if (not (setq Option$ (getkword "\nTroy options : ")))
(setq Option$ "Play")
 );if
 (cond
((= Option$ "Clear")(TroyClear)(princ "\nTroy objects Cleared."))
((= Option$ "Settings")
 	(initget "Troys Speed Colors Defaults")
 	(if (not (setq Settings$ (getkword "\nSettings : ")))
   	(setq Settings$ "Defaults")
 	);if
 	(cond
   	((= Settings$ "Troys")
     	(setq Loop t)
     	(while Loop
       	(if (not (setq *MinTroys#* (getint "\nMinimum number of Troys <5>: ")))
         	(setq *MinTroys#* 5)
       	);if
       	(if (not (setq *MaxTroys#* (getint "\nMaximum number of Troys <10>: ")))
         	(setq *MaxTroys#* 10)
       	);if
       	(if (or (< *MinTroys#* 1) (<= *MaxTroys#* *MinTroys#*))
         	(princ "\nThe maximum number must be greater than the minimum number,\nand the minimum number must be greater than 0.")
         	(setq Loop nil)
       	);if
     	);while
     	(if (> *MaxTroys#* 20)
       	(princ "\nIncreasing the maximum number of Troys may slow down the game.")
     	);if
   	);case
   	((= Settings$ "Speed")
     	(setq Loop t)
     	(while Loop
       	(if (not (setq *TroySpeed~* (getreal "\nAdjust speed of Troys\nEnter a number between 0.5 and 5.0 <1.0>: ")))
         	(setq *TroySpeed~* 1.0)
       	);if
       	(if (or (< *TroySpeed~* 0.5)(> *TroySpeed~* 5.0))
         	(princ "\nThe number must in the range of 0.5 to 5.0.\nThe larger the number the faster the Troys move.")
         	(setq Loop nil)
       	);if
     	);while
   	);case
   	((= Settings$ "Colors")
     	(initget "Bright Dim Ghost")
     	(if (not (setq Colors$ (getkword "\nColor Scheme : ")))
       	(setq Colors$ "Bright")
     	);if
     	(setq *ColorScheme#*
       	(cond
         	((= Colors$ "Bright") 1)
         	((= Colors$ "Dim")	2)
         	((= Colors$ "Ghost")  3)
       	);cond
     	);setq
   	);case
   	((= Settings$ "Defaults")
     	(setq *MinTroys#* 5 *MaxTroys#* 10 *TroySpeed~* 1.0 *ColorScheme#* 1)
   	);case
 	);cond
 	(c:Troy)
);case
(t (Troy Option$))
 );if
 (princ)
);defun c:Troy
;-------------------------------------------------------------------------------
; Troy - Troy main function
;-------------------------------------------------------------------------------
(defun Troy (Option$ / AddArray: Ang~ AxisPt BuildShip: CenPt ChangeArray: CirAng~
 CirEnt^ CirLimits~ CirPt1 CirPt2 Color1 Color1_5 Color2 Color3 Color4 Color5
 Color6 Color7 Color8 Cnt# Code# Counter# CreateArray: Dia1~ Dia2~ Direction#
 Dist~ Ent^ Ent1^ Ent2^ Flame$ Flame^ FlameArray@ HalfStep~ Inc# Inc1~ Inc2~
 Increase~ Item Limit# Loop MainEnt^ MainList@ MainNum# NorthEast NorthWest
 Nth# Nths@ Num# NumSteps# Offset~ OldDirection# Option$ Passed Pnts# Points#
 Previous@ Pt Pt1 Pt2 Pt3 Pt4 Pt5 Pt6 Pt7 Pt8 Pt9 Pt10 Pt11 Pt12 Radius~ Read@
 Refresh: Rotate~ ShipName$ SouthEast SouthWest SS& StepDist~ SubList@ TextEnt^
 Total# TroyArray@ Unit~ Value ViewExtents@ ViewSize~ Xmin~ Xmax~ Ymin~ Ymax~)
 ;-----------------------------------------------------------------------------
 ; AddArray: - Add new Troy entity specs to the TroyArray@ list
 ; Arguments: 1
 ;   StartPt = Specify starting point or nil
 ; Returns: A list of a new random Troy specs to be added to TroyArray@ list
 ;-----------------------------------------------------------------------------
 (defun AddArray: (StartPt / Ang~ Num#)
(if StartPt
 	(setq CirPt1 StartPt)
 	(setq CirPt1 (polar CenPt (* (GetRnd 6283) 0.001) CirLimits~))
);if
(setq Num# (GetRnd 8))
(setq StepDist~;Determines Troys Speed
 	(cond;                               	Points Dia Units
   	((= Num# 0)(* Unit~ 0.100 *TroySpeed~*));50 	2.0
   	((= Num# 1)(* Unit~ 0.125 *TroySpeed~*));75 	2.5
   	((= Num# 2)(* Unit~ 0.150 *TroySpeed~*));100	3.0
   	((= Num# 3)(* Unit~ 0.175 *TroySpeed~*));125	3.5
   	((= Num# 4)(* Unit~ 0.200 *TroySpeed~*));150	4.0
   	((= Num# 5)(* Unit~ 0.225 *TroySpeed~*));175	4.5
   	((= Num# 6)(* Unit~ 0.250 *TroySpeed~*));200	5.0
   	((= Num# 7)(* Unit~ 0.275 *TroySpeed~*));225	5.5
   	((= Num# 8)(* Unit~ 0.300 *TroySpeed~*));250	6.0
 	);cond
);setq
(setq HalfStep~ (/ StepDist~ 2.0))
(setq Points# (+ (* Num# 25) 50));50 to 250
(setq Radius~ (/ (* Unit~ (* 0.1 (+ (+ (* Num# 5) 10) 10))) 2.0))
(command "_CIRCLE" CirPt1 Radius~)
(setq Ent1^ (entlast))
(command "_CHPROP" Ent1^ "" "_C" Color8 "")
(command "_HATCH" "AR-CONC" (* (getvar "VIEWSIZE") 0.0045) "" Ent1^ "")
(setq Ent2^ (entlast))
(command "_CHPROP" Ent2^ "" "_C" Color8 "")
(command "_-GROUP" "_C" (UniqueName) "" Ent1^ Ent2^ "")
(setq CirEnt^ (entlast))
(setq CirAng~ (+ (- (angle CirPt1 CenPt) (dtr 30)) (* (GetRnd 1047) 0.001)))
(setq CirPt2 (polar CirPt1 CirAng~ StepDist~))
(setq Offset~ (+ (* Radius~ 2)(* Radius~ (GetRnd 10))))
(setq Ang~ (atan (/ HalfStep~ Offset~)))
(setq Pt (polar CirPt1 CirAng~ HalfStep~))
(if (< CirAng~ (angle CirPt1 CenPt))
 	(setq AxisPt (polar Pt (+ CirAng~ (dtr 90)) Offset~) Direction# 1)
 	(setq AxisPt (polar Pt (- CirAng~ (dtr 90)) Offset~) Direction# -1)
);if
(setq NumSteps# (+ (GetRnd 10) 2))
(list CirEnt^ CirPt1 CirPt2 AxisPt Radius~ Direction# NumSteps# Points#)
 );defun AddArray:
 ;-----------------------------------------------------------------------------
 ; ChangeArray: - Change or Move entity in the TroyArray@ list
 ; Arguments: 1
 ;   List@ = A sublist within the TroyArray@ list
 ; Returns: Changes or Moves Troy entities in the TroyArray@ list
 ;-----------------------------------------------------------------------------
 (defun ChangeArray: (List@ / Ang~ Num#)
(setq CirEnt^ (nth 0 List@)
     	CirPt1 (nth 1 List@)
     	CirPt2 (nth 2 List@)
     	AxisPt (nth 3 List@)
     	Radius~ (nth 4 List@)
     	Direction# (nth 5 List@)
     	NumSteps# (nth 6 List@)
     	Points# (nth 7 List@)
     	StepDist~ (distance CirPt1 CirPt2)
     	HalfStep~ (/ StepDist~ 2.0)
     	Ang~ (- (* pi 0.5)(acos (/ HalfStep~ (distance AxisPt CirPt2))))
);setq
(command "_MOVE" CirEnt^ "" CirPt1 CirPt2)
(setq NumSteps# (1- NumSteps#))
(if (= NumSteps# 0)
 	(progn
   	(setq NumSteps# (+ (GetRnd 10) 2))
   	(setq OldDirection# Direction#)
   	(setq Num# (GetRnd 10))
   	(if (> Num# 5)
     	(setq Direction# 1);ccw
     	(setq Direction# -1);cw
   	);if
   	(setq Offset~ (+ (* Radius~ 2)(* Radius~ (GetRnd 10))))
   	(if (= OldDirection# 1);ccw
     	(if (= Direction# 1);ccw
       	(setq AxisPt (polar CirPt2 (angle CirPt2 AxisPt) Offset~))
       	(setq AxisPt (polar CirPt2 (angle AxisPt CirPt2) Offset~))
     	);if
     	(if (= Direction# -1);cw
       	(setq AxisPt (polar CirPt2 (angle CirPt2 AxisPt) Offset~))
       	(setq AxisPt (polar CirPt2 (angle AxisPt CirPt2) Offset~))
     	);if
   	);if
   	(setq Ang~ (- (* pi 0.5)(acos (/ HalfStep~ Offset~))))
   	(if (= Direction# 1);ccw
     	(setq Pt (polar AxisPt (+ (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
     	(setq Pt (polar AxisPt (- (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
   	);if
   	(setq CirPt1 CirPt2 CirPt2 Pt)
 	);progn
 	(if (= Direction# 1);ccw
   	(progn
     	(setq Pt (polar AxisPt (+ (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
     	(setq CirPt1 CirPt2 CirPt2 Pt)
   	);progn
   	(progn
     	(setq Pt (polar AxisPt (- (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
     	(setq CirPt1 CirPt2 CirPt2 Pt)
   	);progn
 	);if
);if
;(command "LINE" AxisPt CirPt1 ""); Uncomment to see Troys paths while debuging
;If you're tweaking or debugging this code, you've got to uncommend the above line
;at least once to see these patterns. Run Troy in the Intro or Play mode for about
;10 seconds then press the escape key to abruptly abort the game. Then turn off
;all layers except for the Troy layer, and do a zoom extents and print it.
(list CirEnt^ CirPt1 CirPt2 AxisPt Radius~ Direction# NumSteps# Points#)
 );defun ChangeArray:
 ;-----------------------------------------------------------------------------
 ; CreateArray: - Creates the initial TroyArray@ list
 ; Arguments: 1
 ;   TowardCenter = 1 for toward center, else away from center
 ; Returns: Creates the initial TroyArray@ list moving in direction specified.
 ;-----------------------------------------------------------------------------
 (defun CreateArray: (TowardCenter)
(setq TroyArray@ nil)
(if (= TowardCenter 1)
 	(progn
   	(setq Rotate~ (* (GetRnd 6283) 0.001))
   	(repeat 10
     	(setq TroyArray@ (append TroyArray@ (list (AddArray: (polar CenPt Rotate~ CirLimits~)))))
     	(setq Rotate~ (+ Rotate~ (/ pi 5.0)))
   	);repeat
 	);progn
 	(progn
   	(setq Rotate~ (* (GetRnd 6283) 0.001)
         	Dist~ (/ (distance NorthWest NorthEast) 7)
         	Increase~ (/ (* Dist~ 3) 20.0)
   	);setq
   	(repeat 10
     	(setq Pt (polar CenPt Rotate~ Dist~))
     	(setq List@ (AddArray: Pt))
     	(setq List@ (Switch_nth 1 2 List@))
     	(setq List@ (Change_nth 5 (* (nth 5 List@) -1) List@))
     	(setq TroyArray@ (append TroyArray@ (list List@)))
     	(setq Rotate~ (+ Rotate~ 0.897 (* (GetRnd 359) 0.001))
           	Dist~ (+ Dist~ Increase~)
     	);setq
   	);repeat
 	);progn
);if
 );defun CreateArray:
 ;-----------------------------------------------------------------------------
 ; BuildShip: - Draws Ships
 ; Arguments: 2
 ;   Num# = The number of ship created in the function BuildShip:
 ;   InsPt = Insertion base point of the ship
 ; Returns: Draws and makes a block of ship at the insertion point specified.
 ; Also creates the variables MainEnt^ and MainList@ of the ships specs.
 ;-----------------------------------------------------------------------------
 (defun BuildShip: (Num# InsPt / SS&)
(if (not (member Num# (list 0 1 2 3)))(setq Num# 1))
(cond
 	((= Num# 0);Red Ship in Intro
   	(setq Pt1 (polar InsPt (dtr 90) (* Unit~ 0.5))
         	Pt1 (polar Pt1 pi (* Unit~ 0.875))
         	Pt2 (polar Pt1 pi (* Unit~ 0.375))
         	Pt2 (polar Pt2 (dtr 270) (* Unit~ 0.125))
         	Pt3 (polar Pt2 pi (* Unit~ 0.25))
         	Pt3 (polar Pt3 (dtr 270) (* Unit~ 0.125))
         	Pt4 (polar Pt3 (dtr 270) (* Unit~ 0.75))
         	Pt4 (polar Pt4 0 (* Unit~ 0.5))
         	Pt5 (polar Pt4 0 (* Unit~ 1.25))
         	Pt5 (polar Pt5 (dtr 270) (* Unit~ 0.5))
         	Pt6 (polar InsPt 0 (* Unit~ 2.5))
         	Pt7 (polar Pt6 (dtr 90) (* Unit~ 0.5))
         	Pt7 (polar Pt7 pi Unit~)
         	Pt8 (polar Pt7 pi (* Unit~ 0.5))
         	Pt8 (polar Pt8 (dtr 90) (* Unit~ 0.125))
         	Pt9 (polar Pt3 0 (* Unit~ 0.5))
         	Pt10 (polar InsPt (dtr 270) (* Unit~ 0.25))
         	Pt11 (polar Pt9 0 (* Unit~ 2.25))
         	Pt12 (polar InsPt (dtr 90) Unit~)
   	);setq
   	(setq SS& (ssadd))
   	(command "_COLOR" Color1);Red
   	(command "_ARC" Pt1 Pt2 Pt3)(ssadd (entlast) SS&)
   	(command "_ARC" Pt3 Pt4 Pt5)(ssadd (entlast) SS&)
   	(command "_ARC" "" Pt6)(ssadd (entlast) SS&)
   	(command "_ARC" Pt6 Pt7 Pt8)(ssadd (entlast) SS&)
   	(command "_COLOR" Color4);Cyan
   	(command "_ARC" Pt9 Pt10 Pt11)(ssadd (entlast) SS&)
   	(command "_ARC" Pt11 Pt12 Pt9)(ssadd (entlast) SS&)
   	(command "_COLOR" "_BYLAYER")
   	(setq ShipName$ (UniqueName))
   	(command "_BLOCK" ShipName$ InsPt SS& "")
   	(command "_INSERT" ShipName$ InsPt 1 1 0)
   	(setq MainEnt^ (entlast))
   	(setq MainList@ (entget MainEnt^))
 	);case
 	((= Num# 1);Green Ship
   	(setq Pt (polar InsPt pi Unit~) Pt (polar Pt (dtr 90) (* Unit~ 0.5)))
   	(command "_PLINE" Pt (polar Pt (dtr 270) Unit~) (polar InsPt 0 (* Unit~ 2)) "_C")
   	(command "_CHPROP" "_L" "" "_C" Color3 "");Green
   	(setq ShipName$ (UniqueName))
   	(command "_BLOCK" ShipName$ InsPt "_L" "")
   	(command "_INSERT" ShipName$ InsPt 1 1 0)
   	(setq MainEnt^ (entlast))
   	(setq MainList@ (entget MainEnt^))
 	);case
 	((= Num# 2);Cyan Ship
   	(setq Pt (polar InsPt pi Unit~) Pt1 (polar Pt (dtr 270) Unit~)
         	Pt4 (polar Pt1 (dtr 90) (* Unit~ 2)) Pt (polar InsPt 0 Unit~)
         	Pt2 (polar Pt (dtr 270) (* Unit~ 0.5)) Pt3 (polar Pt2 (dtr 90) Unit~)
   	);setq
   	(command "_PLINE" (polar InsPt pi (* Unit~ 0.5)) Pt1 (polar InsPt (dtr 270) (* Unit~ 0.5))
     	Pt2 (polar InsPt 0 (* Unit~ 2)) Pt3 (polar InsPt (dtr 90) (* Unit~ 0.5)) Pt4 "_C"
   	);command
   	(command "_CHPROP" "_L" "" "_C" Color4 "");Cyan
   	(setq ShipName$ (UniqueName))
   	(command "_BLOCK" ShipName$ InsPt "_L" "")
   	(command "_INSERT" ShipName$ InsPt 1 1 0)
   	(setq MainEnt^ (entlast))
   	(setq MainList@ (entget MainEnt^))
 	);case
 	((= Num# 3);Magenta Ship
   	(setq Pt (polar InsPt pi Unit~) Pt1 (polar Pt (dtr 270) (* Unit~ 0.5))
         	Pt4 (polar Pt1 (dtr 90) Unit~) Pt2 (polar Pt1 0 (* Unit~ 1.5))
         	Pt3 (polar Pt4 0 (* Unit~ 1.5))
   	);setq
   	(command "_PLINE" InsPt Pt1 (polar InsPt (dtr 270) Unit~) Pt2
     	(polar InsPt 0 (* Unit~ 2)) Pt3 (polar InsPt (dtr 90) Unit~) Pt4 "_C"
   	);command
   	(command "_CHPROP" "_L" "" "_C" Color6 "");Magenta
   	(setq ShipName$ (UniqueName))
   	(command "_BLOCK" ShipName$ InsPt "_L" "")
   	(command "_INSERT" ShipName$ InsPt 1 1 0)
   	(setq MainEnt^ (entlast))
   	(setq MainList@ (entget MainEnt^))
 	);case
);cond
(princ)
 );defun BuildShip:
 ;-----------------------------------------------------------------------------
 ; Refresh: - Erases Troy entities and creates a new TroyArray@ list
 ;-----------------------------------------------------------------------------
 (defun Refresh: ()
(setq SS& (ssget "_x" (list '(8 . "Troy"))))
(command "_ERASE" SS& "")
(setq FlameArray@ nil TroyArray@ nil Counter# 0 MainNum# (1+ MainNum#))
(CreateArray: (GetRnd 1))
(princ)
 );defun Refresh:
 ;=============================================================================
 ; Start of Main Function
 ;=============================================================================
 (if (not *MinTroys#*) (setq *MinTroys#* 5))
 (if (not *MaxTroys#*) (setq *MaxTroys#* 10))
 (if (not *TroySpeed~*) (setq *TroySpeed~* 1.0))
 (if (not *ColorScheme#*) (setq *ColorScheme#* 1))
 (if (not *Speed#) (Speed))
 (if (not *Clayer$*) (setq *Clayer$* (getvar "CLAYER")))
 (if (not *Osmode#*) (setq *Osmode#* (getvar "OSMODE")))
 (if (not *TextStyle$*) (setq *TextStyle$* (getvar "TEXTSTYLE")))
 (if (not *TextSize~*) (setq *TextSize~* (getvar "TEXTSIZE")))
 (setvar "BLIPMODE" 0)(setvar "CMDECHO" 0)
 (setvar "OSMODE" 0)(setvar "GRIDMODE" 0)(graphscr)
 (if (>= (atoi (getvar "ACADVER")) 15)
(progn
 	(if (not *CTab$*) (setq *CTab$* (getvar "CTAB")))
 	(if (/= (getvar "CTAB") "Model")
   	(progn
     	(command "_PSPACE")
     	(if (setq SS& (ssget "_x" (list '(-4 . "<AND")'(0 . "VIEWPORT")(cons 410 (getvar "CTAB"))'(-4 . "AND>"))))
       	(if (> (sslength SS&) 1)
         	(command "_LAYOUT" "_S" "Model")
       	);if
     	);if
   	);progn
 	);if
 	(setq *TroyTab$* (getvar "CTAB"))
);progn
 );if
 (if (tblsearch "LAYER" "Troy")
(command "_LAYER" "_T" "Troy" "_U" "Troy" "_ON" "Troy" "_M" "Troy" "")
(command "_LAYER" "_M" "Troy" "")
 );if
 (if (setq SS& (ssget "_x" (list '(8 . "Troy"))))
(command "_ERASE" SS& "")
 );if
 (setq ViewExtents@ (ViewExtents))
 (command "_ZOOM" "_W" (car ViewExtents@)(cadr ViewExtents@))
 (setq Xmin~ (car (nth 0 ViewExtents@))
   	Ymax~ (cadr (nth 0 ViewExtents@))
   	Xmax~ (car (nth 1 ViewExtents@))
   	Ymin~ (cadr (nth 1 ViewExtents@))
   	NorthWest (car ViewExtents@)
   	SouthEast (cadr ViewExtents@)
   	SouthWest (list Xmin~ Ymin~)
   	NorthEast (list Xmax~ Ymax~)
   	CenPt (getvar "VIEWCTR")
   	ViewSize~ (getvar "VIEWSIZE")
   	Unit~ (/ (getvar "VIEWSIZE") 50.0)
   	Limit# (1+ (fix (/ (distance CenPt (car ViewExtents@)) Unit~)))
   	CirLimits~ (* (+ Limit# 3) Unit~)
   	North (polar CenPt (dtr 90) (+ (* Unit~ 3) (/ (getvar "VIEWSIZE") 2.0)))
   	South (polar CenPt (dtr 270) (+ (* Unit~ 3) (/ (getvar "VIEWSIZE") 2.0)))
   	East (polar CenPt 0 (+ (* Unit~ 3) (/ (distance NorthWest NorthEast) 2.0)))
   	West (polar CenPt pi (+ (* Unit~ 3) (/ (distance NorthWest NorthEast) 2.0)))
 );setq
 ; Customize Color Schemes as desired and add to top menu in c:Troy
 (cond
((= *ColorScheme#* 1);  Bright colors
 	(setq Color1 	1 ;Red  	Red ship
       	Color1_5  30 ;Orange   Exploding Troys
       	Color2 	2 ;Yellow   Bonus points
       	Color3 	3 ;Green	1st ship
       	Color4 	4 ;Cyan 	2nd ship
       	Color5 	5 ;Blue 	Letter O in TroyIntro
       	Color6 	6 ;Magenta  3rd ship
       	Color7 	7 ;White	Not used
       	Color8	33 ;Grey 	Troys
 	);setq
);case
((= *ColorScheme#* 2);  Dim colors
 	(setq Color1	12 ;Red  	Red ship
       	Color1_5  32 ;Orange   Exploding Troys
       	Color2	52 ;Yellow   Bonus points
       	Color3	86 ;Green	1st ship
       	Color4   152 ;Cyan 	2nd ship
       	Color5   162 ;Blue 	Letter O in TroyIntro
       	Color6   192 ;Magenta  3rd ship
       	Color7 	7 ;White	Not used
       	Color8   250 ;Grey 	Troys
 	);setq
);case
((= *ColorScheme#* 3);  Ghost colors
 	(setq Color1   250 ;Red  	Red ship
       	Color1_5 250 ;Orange   Exploding Troys
       	Color2   250 ;Yellow   Bonus points
       	Color3   250 ;Green	1st ship
       	Color4   250 ;Cyan 	2nd ship
       	Color5   250 ;Blue 	Letter O in TroyIntro
       	Color6   250 ;Magenta  3rd ship
       	Color7   250 ;White	Not used
       	Color8   250 ;Grey 	Troys
 	);setq
);case
 );cond
 ; Create Flame$ block
 (setq SS& (ssadd))(setq Pt SouthEast)
 (command "_COLOR" Color2);Yellow
 (command "_LINE" Pt (setq Pt (polar Pt 0 Unit~)) "")(ssadd (entlast) SS&)
 (command "_COLOR" Color1);Red
 (command "_LINE" Pt (setq Pt (polar Pt 0 Unit~)) "")(ssadd (entlast) SS&)
 (command "_COLOR" "_BYLAYER")(setq Flame$ (UniqueName))
 (command "_BLOCK" Flame$ SouthEast SS& "")
 (if (= Option$ "Intro")(TroyIntro))
 ;(command "RECTANG" (car ViewExtents@)(cadr ViewExtents@)); Uncomment while debuging
 ;(command "CIRCLE" CenPt CirLimits~); Uncomment while debuging
 ; Build Ship 1
 (BuildShip: 1 CenPt)
 ; Create first Troys
 (CreateArray: (GetRnd 1))
 (command "_STYLE" "Troy" "ROMANS" "0.0" "0.75" "" "" "" "")
 ;-----------------------------------------------------------------------------
 ; Start of grread Loop
 ;-----------------------------------------------------------------------------
 (setq Loop t Counter# 0 Total# 100 MainNum# 1)
 (setq Previous@ (list 5 (polar CenPt 0 Unit~)));Start the Loop moving
 (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
 (while Loop
; Read the mouse movements and picks
(if (not (setq Read@ (grread t 8)))
 	(setq Read@ Previous@)
);if
(setq Code# (nth 0 Read@))
(setq Value (nth 1 Read@))
(cond
 	((= Code# 3); Fire if picked
   	(setq Ang~ (angle CenPt Value)
         	Pt1 (polar CenPt Ang~ (* Unit~ 2))
         	Pt2 (polar Pt1 Ang~ Unit~)
   	);setq
   	(command "_INSERT" Flame$ Pt1 1 1 (rtd Ang~))
   	(setq FlameArray@ (append FlameArray@ (list (list (entlast) Pt1 Pt2 Ang~))))
   	(setq Total# (1- Total#))
   	(princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
 	);case
 	((= Code# 5); Rotate if moved
   	(setq Previous@ Read@)
   	(setq Ang~ (angle CenPt Value))
   	(setq MainList@ (entmod (subst (cons 50 Ang~) (assoc 50 MainList@) MainList@)))
 	);case
 	((= Code# 2); Key was pressed
   	(cond
     	((or (= Value 80)(= Value 112));P or p then pause
       	(getpoint "\nTroy paused.  Pick mouse to continue. ")
       	(princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
     	);case
     	((or (= Value 81)(= Value 113));Q or q then quit
       	(setq Loop nil)
     	);case
     	(t (princ "\nMove mouse to rotate ship, pick mouse to fire, press P to Pause, or Q to quit.")
        	(princ (strcat "\nTotal: " (itoa Total#) "\n"))
     	);case
   	);case
 	);case
);cond
; Move flame objects
(if FlameArray@
 	(progn
   	(setq Cnt# 0 Nths@ nil)
   	(foreach List@ FlameArray@
     	(setq Flame^ (nth 0 List@)
           	Pt1 (nth 1 List@)
           	Pt2 (nth 2 List@)
           	Ang~ (nth 3 List@)
     	);setq
     	(if (or (and (> (car Pt2)(car East))(> (car Pt2)(car Pt1)))
             	(and (< (car Pt2)(car West))(< (car Pt2)(car Pt1)))
             	(and (> (cadr Pt2)(cadr North))(> (cadr Pt2)(cadr Pt1)))
             	(and (< (cadr Pt2)(cadr South))(< (cadr Pt2)(cadr Pt1)))
         	);or
       	(progn
         	(command "_ERASE" Flame^ "")
         	(setq Nths@ (append Nths@ (list Cnt#)))
       	);progn
       	(progn
         	(command "_MOVE" Flame^ "" Pt1 Pt2)
         	(setq Pt1 Pt2 Pt2 (polar Pt2 Ang~ Unit~))
         	(setq List@ (list Flame^ Pt1 Pt2 Ang~))
         	(setq FlameArray@ (Change_nth Cnt# List@ FlameArray@))
       	);progn
     	);if
     	(setq Cnt# (1+ Cnt#))
   	);foreach
   	(if Nths@
     	(setq FlameArray@ (Remove_nths Nths@ FlameArray@))
   	);if
 	);progn
);if
; Check if Troys are hit
(setq Cnt# 0 Nths@ nil)
(foreach List@ TroyArray@ ; Troy list
 	(if FlameArray@ ; Flame list
   	(progn
     	(setq CirEnt^ (nth 0 List@)
           	CirPt1 (nth 1 List@)
           	Radius~ (nth 4 List@)
           	Points# (nth 7 List@)
     	);setq
     	(setq Num# 0 Num@ nil)
     	(foreach SubList@ FlameArray@
       	(setq Flame^ (nth 0 SubList@)
             	Pt2 (nth 2 SubList@)
       	);setq
       	(if (and (> (car Pt2) (+ Xmin~ Radius~))(< (car Pt2) (- Xmax~ Radius~))
                	(> (cadr Pt2) (+ Ymin~ Radius~))(< (cadr Pt2) (- Ymax~ Radius~)))
         	(if (<= (distance Pt2 CirPt1) Radius~)
           	(progn
             	(command "_ERASE" CirEnt^ Flame^ "")
             	(setq Num@ (append Num@ (list Num#)))
             	(setq Nths@ (append Nths@ (list Cnt#)))
             	(command "_TEXT" "_M" CirPt1 Unit~ 0 (itoa Points#))
             	(command "_CHPROP" "_L" "" "_C" Color2 "")
             	(setq TextEnt^ (entlast))
             	(setq Total# (+ Total# Points#))
             	(princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
             	(command "_COLOR" Color1_5)
             	(setq Dia1~ (* Radius~ 2) Dia2~ (* Radius~ 3) Ang~ (dtr 270) Pnts# 7)
             	(repeat 3
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3.5) Ang~ (+ Ang~ (/ (* pi 2) (* Pnts# 3))))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3) Ang~ (dtr 90))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3.5) Ang~ (- Ang~ (/ (* pi 2) (* Pnts# 3))))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3) Ang~ (dtr 270))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3.5) Ang~ (- Ang~ (/ (* pi 2) (* Pnts# 3))))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3) Ang~ (dtr 90))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3.5) Ang~ (+ Ang~ (/ (* pi 2) (* Pnts# 3))))
               	(command "_ERASE" (entlast) "")
               	(StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
               	(setq Dia2~ (* Radius~ 3) Ang~ (dtr 270))
               	(command "_ERASE" (entlast) "")
             	);repeat
             	(command "_COLOR" "_BYLAYER")
             	(command "_ERASE" TextEnt^"")
           	);progn
         	);if
       	);if
       	(setq Num# (1+ Num#))
     	);foreach
     	(if Num@
       	(setq FlameArray@ (Remove_nths Num@ FlameArray@))
     	);if
   	);progn
 	);if
 	(if TroyArray@
   	(setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
   	(CreateArray: 1)
 	);if
 	(setq Cnt# (1+ Cnt#))
);foreach
(if Nths@
 	(setq TroyArray@ (Remove_nths Nths@ TroyArray@))
);if
(if (not TroyArray@)
 	(CreateArray: 1)
);if
; Erase Troys that are out of limits
(setq Cnt# 0)
(foreach List@ TroyArray@
 	(setq CirEnt^ (nth 0 List@)
       	CirPt1 (nth 1 List@)
       	CirPt2 (nth 2 List@)
 	);setq
 	(if (or (and (> (car CirPt1)(car East))(> (car CirPt2)(car CirPt1)))
         	(and (< (car CirPt1)(car West))(< (car CirPt2)(car CirPt1)))
         	(and (> (cadr CirPt1)(cadr North))(> (cadr CirPt2)(cadr CirPt1)))
         	(and (< (cadr CirPt1)(cadr South))(< (cadr CirPt2)(cadr CirPt1)))
     	);or
   	(progn
     	(command "_ERASE" CirEnt^ "")
     	(setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
     	(setq Counter# (1+ Counter#))
     	(if (= Counter# 3);Add Troys per Counter#
       	(progn
         	(setq Counter# 0)
         	(if (< (length TroyArray@) *MaxTroys#*)
           	(setq TroyArray@ (append TroyArray@ (list (AddArray: nil))))
         	);if
       	);progn
     	);if
   	);progn
 	);if
 	(setq Cnt# (1+ Cnt#))
);foreach
; Check if Troys ran into Ship or total points is <= 0
(setq Cnt# 0 Passed t)
(while Passed
 	(setq List@ (nth Cnt# TroyArray@)
       	CirEnt^ (nth 0 List@)
       	CirPt1 (nth 1 List@)
       	Radius~ (nth 4 List@)
 	);setq
 	(if (or (< (distance CenPt CirPt1) (+ Radius~ (* Unit~ 2.5))) (<= Total# 0))
   	(progn
     	(command "_ERASE" MainEnt^ "")
     	(cond
       	((= MainNum# 1)(setq Color# Color3));Green
       	((= MainNum# 2)(setq Color# Color4));Cyan
       	((= MainNum# 3)(setq Color# Color6));Magenta
     	);cond
     	(command "_COLOR" Color#)
     	(setq Dia1~ 1 Dia2~ 4 Ang~ (dtr 270) Inc# 0 Inc1~ 0.125 Inc2~ 0.375)
     	(repeat 20
       	(if (= Inc# 11)(setq Inc1~ -0.125 Inc2~ -0.375))
       	(StarBurst CenPt (* Unit~ Dia1~) (* Unit~ Dia2~) 5 Ang~)(delay 0.5)
       	(setq Dia1~ (+ Dia1~ Inc1~) Dia2~ (+ Dia2~ Inc2~))
       	(setq Ang~ (+ Ang~ (/ (* pi 2) 3)))
       	(command "_ERASE" (entlast) "")
       	(setq Inc# (1+ Inc#))
     	);repeat
     	(command "_COLOR" "_BYLAYER")
     	(setq Total# (- Total# 10))
     	(if (<= Total# 0)
       	(progn
         	(setq MainNum# 3)
         	(princ "\nCommand:\nTotal: 0")
       	);progn
       	(princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
     	);if
     	(cond
       	((= MainNum# 1); Build Ship 2
         	(Refresh:)
         	(BuildShip: 2 CenPt)
       	);case
       	((= MainNum# 2); Build Ship 3
         	(Refresh:)
         	(BuildShip: 3 CenPt)
       	);case
       	((= MainNum# 3); Finished!
         	(setq Passed nil Loop nil)
       	);case
     	);cond
     	(setq Passed nil)
   	);progn
 	);if
 	(setq Cnt# (1+ Cnt#))
 	(if (> Cnt# (1- (length TroyArray@)))
   	(setq Passed nil)
 	);if
);while
(if (< (length TroyArray@) *MinTroys#*)
 	(setq TroyArray@ (append TroyArray@ (list (AddArray: nil))))
);if
(if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
 	(command "_ZOOM" "_W" (car ViewExtents@)(cadr ViewExtents@))
);if
 );while
 (TroyClear)
 (princ (strcat "\nCommand:\nTotal: " (itoa Total#) " Finished!"))
 (princ)
);defun Troy
;-------------------------------------------------------------------------------
; TroyIntro - Introduction
;-------------------------------------------------------------------------------
(defun TroyIntro (/ Color# Divisions# Fire# Fourth# Inc~ Increase~ Ltr# Move#
 O-Ang~ O-Cnt# O-Ent^ O-Ins O-List@ O-Pt O-Pts@ O-Size~ Path# Path@ Path1@
 Path2@ Path3@ Path4@ R-Ang~ R-Cen R-Cnt# R-Ent^ R-Ins R-List@ R-Pt R-Pts@
 R-Size~ Rotate~ Rnd# RndLtr@ Sevenths Step~ T-Ang~ T-Cen T-Cnt# T-Ent^ T-Ins
 T-List@ T-Pt T-Pts@ T-Size~ Tl-Ang~ TxSize~ TxSizeInc~ TxSizeMax~ TxSizeMin~
 Y-Ang~ Y-Cnt# Y-Ent^ Y-Ins Y-List@ Y-Pt Y-Pts@ Y-Size~)
 (princ "\nTroy Intro.\n")
 (command "_STYLE" "Troy" "ROMAND" "0.0" "1" "" "" "" "")
 (setq T-Pt (polar CenPt pi (* Unit~ 4.5))
   	R-Pt (polar CenPt pi (* Unit~ 1.5))
   	O-Pt (polar CenPt 0 (* Unit~ 1.5))
   	Y-Pt (polar CenPt 0 (* Unit~ 4.5))
   	TxSizeMax~ (* Unit~ 3)
   	TxSizeMin~ (* Unit~ 0.5)
   	Inc~ (* Unit~ 2);Speed of letters
   	Pt0 (polar R-Pt (- (angle R-Pt SouthWest) 0.009) (distance R-Pt SouthWest))
   	Pt (polar R-Pt (angle R-Pt Pt0) (/ (distance R-Pt Pt0) 2.0))
   	Pt (polar Pt (+ (angle R-Pt Pt0) (* pi 0.5)) (/ (distance R-Pt Pt0) 7.0))
   	R-Cen (Center3Pt R-Pt Pt Pt0)
   	Radius~ (distance R-Pt R-Cen)
   	Ang~ (* (- (* pi 0.5) (acos (/ (/ Inc~ 2.0) Radius~))) 2)
   	Inc# (fix (/ (- (angle R-Cen R-Pt) (angle R-Cen SouthWest)) Ang~))
   	Pt0 (polar T-Pt (- (angle T-Pt NorthWest) 0.043) (distance R-Pt SouthWest))
   	Pt (polar T-Pt (angle T-Pt Pt0) (/ (distance R-Pt Pt0) 2.0))
   	Pt (polar Pt (+ (angle T-Pt Pt0) (* pi 0.5)) (/ (distance R-Pt Pt0) 7.0))
   	T-Cen (Center3Pt T-Pt Pt Pt0)
   	TxSizeInc~ (/ (- TxSizeMax~ TxSizeMin~) (float Inc#))
   	TxSize~ TxSizeMax~
   	T-Pts@ (list T-Pt)
   	R-Pts@ (list R-Pt)
   	O-Pts@ (list O-Pt)
   	Y-Pts@ (list Y-Pt)
   	T-Ang~ 0
 );setq
 (repeat Inc#
(setq T-Pt (polar T-Cen (- (angle T-Cen T-Pt) Ang~) Radius~)
     	T-Pts@ (append T-Pts@ (list T-Pt))
     	R-Pt (polar R-Cen (- (angle R-Cen R-Pt) Ang~) Radius~)
     	R-Pts@ (append R-Pts@ (list R-Pt))
     	O-Pt (polar CenPt (angle R-Pt CenPt) (distance R-Pt CenPt))
     	O-Pts@ (append O-Pts@ (list O-Pt))
     	Y-Pt (polar CenPt (angle T-Pt CenPt) (distance T-Pt CenPt))
     	Y-Pts@ (append Y-Pts@ (list Y-Pt))
     	T-Ang~ (- T-Ang~ (dtr 30))
     	TxSize~ (- TxSize~ TxSizeInc~)
);setq
 );repeat
 (setq T-Pts@ (reverse T-Pts@)
   	R-Pts@ (reverse R-Pts@)
   	O-Pts@ (reverse O-Pts@)
   	Y-Pts@ (reverse Y-Pts@)
   	R-Ang~ T-Ang~ O-Ang~ T-Ang~ Y-Ang~ T-Ang~
   	T-Size~ TxSize~ R-Size~ TxSize~ O-Size~ TxSize~ Y-Size~ TxSize~
   	T-Cnt# 0 R-Cnt# 0 O-Cnt# 0 Y-Cnt# 0 Fourth# (/ Inc# 4)
 );setq
 (setq T-Pt (last T-Pts@) R-Pt (last R-Pts@) O-Pt (last O-Pts@) Y-Pt (last Y-Pts@) RndLtr@ (list 0))
 (while (/= (length RndLtr@) 5)
(setq Rnd# (1+ (GetRnd 3)))
(cond
 	((= Rnd# 1)(setq Pt T-Pt))
 	((= Rnd# 2)(setq Pt R-Pt))
 	((= Rnd# 3)(setq Pt O-Pt))
 	((= Rnd# 4)(setq Pt Y-Pt))
);cond
(if (not (member Pt RndLtr@))
 	(setq RndLtr@ (append RndLtr@ (list Pt)))
);if
 );while
 (setq Rotate~ (* (GetRnd 6283) 0.001)
   	Dist~ (/ (distance NorthWest NorthEast) 10)
   	Increase~ (/ (* Dist~ 3) 20.0)
 );setq
 (repeat 20
(setq Pt (polar CenPt Rotate~ Dist~))
(setq List@ (AddArray: Pt))
(setq List@ (Switch_nth 1 2 List@))
(setq List@ (Change_nth 5 (* (nth 5 List@) -1) List@))
(setq TroyArray@ (append TroyArray@ (list List@)))
(setq Rotate~ (+ Rotate~ 0.897 (* (GetRnd 359) 0.001))
     	Dist~ (+ Dist~ Increase~)
);setq
 );repeat
 (setq Step~ (* Unit~ 1.5);Speed of red ship
   	Pt1 (polar SouthWest (dtr 90) (/ (distance SouthWest NorthWest) 6.0))
   	Pt2 (polar Pt1 0 (/ (distance SouthWest SouthEast) 3.0))
   	Pt (polar Pt1 0 (/ (distance Pt1 Pt2) 2.0))
   	Pt (polar Pt (dtr 90) (* Unit~ 2))
   	Pt (Center3Pt Pt1 Pt Pt2)
   	Radius~ (distance Pt Pt1)
   	Tl-Ang~ (- (angle Pt Pt1) (angle Pt Pt2))
   	Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
   	Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
   	Pt2 (polar Pt (- (angle Pt Pt1) (* Ang~ Divisions#)) Radius~)
 );setq
 (setq Path1@ (list Pt1))
 (repeat Divisions#
(setq Pt1 (polar Pt (- (angle Pt Pt1) Ang~) Radius~))
(setq Path1@ (append Path1@ (list Pt1)))
 );repeat
 (setq Pt (polar Pt (angle Pt Pt2) (* Radius~ 2)))
 (repeat (fix (1+ (/ Divisions# 2.0)))
(setq Pt1 (polar Pt (+ (angle Pt Pt1) Ang~) Radius~))
(if (< (angle Pt Pt1) (dtr 270))
 	(setq Path1@ (append Path1@ (list Pt1)))
);if
 );repeat
 (setq Pt1 (last Path1@)
   	Pt2 (inters Pt1 (polar Pt1 0 Unit~) NorthEast SouthEast nil)
   	Ang~ (atan (/ 1 2.0))
   	Radius~ (* (distance Pt1 Pt2) (tan Ang~))
   	Pt (polar Pt1 (dtr 90) Radius~)
   	Tl-Ang~ (atan (/ (distance Pt1 Pt2) Radius~))
   	Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
   	Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
 );setq
 (repeat Divisions#
(setq Pt1 (polar Pt (+ (angle Pt Pt1) Ang~) Radius~))
(setq Path1@ (append Path1@ (list Pt1)))
 );repeat
 (setq Pt Pt2
   	Radius~ (distance Pt Pt1)
   	Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
   	Tl-Ang~ (- (angle Pt Pt1) (* pi 0.5))
   	Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
 );setq
 (repeat Divisions#
(setq Pt2 Pt1)
(setq Pt1 (polar Pt (- (angle Pt Pt1) Ang~) Radius~))
(if (> (angle Pt Pt1) (* pi 0.5))
 	(setq Path1@ (append Path1@ (list Pt1)))
);if
 );repeat
 (setq Ang~ (angle Pt2 Pt1))
 (repeat 5
(setq Pt1 (polar Pt1 Ang~ Step~))
(setq Path1@ (append Path1@ (list Pt1)))
 );repeat
 (setq Ang~ (angle (nth 1 Path1@) (nth 0 Path1@)))
 (repeat 5
(setq Pt (polar (nth 0 Path1@) Ang~ Step~))
(setq Path1@ (Insert_nth 0 Pt Path1@))
 );repeat
 (foreach Item Path1@
(setq Pt2 (MirrorPt Item CenPt 0))
(setq Path2@ (append Path2@ (list Pt2)))
(setq Pt3 (MirrorPt Item CenPt (dtr 90)))
(setq Path3@ (append Path3@ (list Pt3)))
(setq Pt4 (MirrorPt Pt3 CenPt 0))
(setq Path4@ (append Path4@ (list Pt4)))
 );foreach
 (setq Path# (1+ (GetRnd 3)))
 (cond
((= Path# 1)(setq Path@ Path1@))
((= Path# 2)(setq Path@ Path2@))
((= Path# 3)(setq Path@ Path3@))
((= Path# 4)(setq Path@ Path4@))
 );cond
 ;-----------------------------------------------------------------------------
 ; First Loop
 ;-----------------------------------------------------------------------------
 (setq Loop t)
 (while Loop
(if (<= T-Cnt# Inc#)
 	(if (= T-Cnt# 0)
   	(progn
     	(command "_TEXT" "_M" (nth T-Cnt# T-Pts@) T-Size~ (rtd T-Ang~) "T")
     	(setq T-Ent^ (entlast))
     	(command "_CHPROP" T-Ent^ "" "_C" Color3 "");Green
     	(setq T-List@ (entget T-Ent^)
           	T-Size~ (+ T-Size~ TxSizeInc~)
           	T-Ang~ (+ T-Ang~ (dtr 30))
           	T-Cnt# (1+ T-Cnt#)
           	T-Ins (nth T-Cnt# T-Pts@)
     	);setq
   	);progn
   	(progn
     	(setq T-List@ (entmod (subst (cons 50 T-Ang~) (assoc 50 T-List@) T-List@)))
     	(setq T-List@ (entmod (subst (cons 11 T-Ins) (assoc 11 T-List@) T-List@)))
     	(setq T-List@ (entmod (subst (cons 40 T-Size~) (assoc 40 T-List@) T-List@)))
     	(setq T-Size~ (+ T-Size~ TxSizeInc~)
           	T-Ang~ (+ T-Ang~ (dtr 30))
           	T-Cnt# (1+ T-Cnt#)
     	);setq
     	(if (<= T-Cnt# Inc#) (setq T-Ins (nth T-Cnt# T-Pts@)))
   	);progn
 	);if
);if
(if (>= T-Cnt# Fourth#)
 	(if (<= R-Cnt# Inc#)
   	(if (= R-Cnt# 0)
     	(progn
       	(command "_TEXT" "_M" (nth R-Cnt# R-Pts@) R-Size~ (rtd R-Ang~) "R")
       	(setq R-Ent^ (entlast))
       	(command "_CHPROP" R-Ent^ "" "_C" Color4 "");Cyan
       	(setq R-List@ (entget R-Ent^)
             	R-Size~ (+ R-Size~ TxSizeInc~)
             	R-Ang~ (+ R-Ang~ (dtr 30))
             	R-Cnt# (1+ R-Cnt#)
             	R-Ins (nth R-Cnt# R-Pts@)
       	);setq
     	);progn
     	(progn
       	(setq R-List@ (entmod (subst (cons 50 R-Ang~) (assoc 50 R-List@) R-List@)))
       	(setq R-List@ (entmod (subst (cons 11 R-Ins) (assoc 11 R-List@) R-List@)))
       	(setq R-List@ (entmod (subst (cons 40 R-Size~) (assoc 40 R-List@) R-List@)))
       	(setq R-Size~ (+ R-Size~ TxSizeInc~)
             	R-Ang~ (+ R-Ang~ (dtr 30))
             	R-Cnt# (1+ R-Cnt#)
       	);setq
       	(if (<= R-Cnt# Inc#) (setq R-Ins (nth R-Cnt# R-Pts@)))
     	);progn
   	);if
 	);if
);if
(if (>= R-Cnt# Fourth#)
 	(if (<= O-Cnt# Inc#)
   	(if (= O-Cnt# 0)
     	(progn
       	(command "_TEXT" "_M" (nth O-Cnt# O-Pts@) O-Size~ (rtd O-Ang~) "O")
       	(setq O-Ent^ (entlast))
       	(command "_CHPROP" O-Ent^ "" "_C" Color5 "");Blue
       	(setq O-List@ (entget O-Ent^)
             	O-Size~ (+ O-Size~ TxSizeInc~)
             	O-Ang~ (+ O-Ang~ (dtr 30))
             	O-Cnt# (1+ O-Cnt#)
             	O-Ins (nth O-Cnt# O-Pts@)
       	);setq
     	);progn
     	(progn
       	(setq O-List@ (entmod (subst (cons 50 O-Ang~) (assoc 50 O-List@) O-List@)))
       	(setq O-List@ (entmod (subst (cons 11 O-Ins) (assoc 11 O-List@) O-List@)))
       	(setq O-List@ (entmod (subst (cons 40 O-Size~) (assoc 40 O-List@) O-List@)))
       	(setq O-Size~ (+ O-Size~ TxSizeInc~)
             	O-Ang~ (+ O-Ang~ (dtr 30))
             	O-Cnt# (1+ O-Cnt#)
       	);setq
       	(if (<= O-Cnt# Inc#) (setq O-Ins (nth O-Cnt# O-Pts@)))
     	);progn
   	);if
 	);if
);if
(if (>= O-Cnt# Fourth#)
 	(if (<= Y-Cnt# Inc#)
   	(if (= Y-Cnt# 0)
     	(progn
       	(command "_TEXT" "_M" (nth Y-Cnt# Y-Pts@) Y-Size~ (rtd Y-Ang~) "Y")
       	(setq Y-Ent^ (entlast))
       	(command "_CHPROP" Y-Ent^ "" "_C" Color6 "");Magenta
       	(setq Y-List@ (entget Y-Ent^)
             	Y-Size~ (+ Y-Size~ TxSizeInc~)
             	Y-Ang~ (+ Y-Ang~ (dtr 30))
             	Y-Cnt# (1+ Y-Cnt#)
             	Y-Ins (nth Y-Cnt# Y-Pts@)
       	);setq
     	);progn
     	(progn
       	(setq Y-List@ (entmod (subst (cons 50 Y-Ang~) (assoc 50 Y-List@) Y-List@)))
       	(setq Y-List@ (entmod (subst (cons 11 Y-Ins) (assoc 11 Y-List@) Y-List@)))
       	(setq Y-List@ (entmod (subst (cons 40 Y-Size~) (assoc 40 Y-List@) Y-List@)))
       	(setq Y-Size~ (+ Y-Size~ TxSizeInc~)
             	Y-Ang~ (+ Y-Ang~ (dtr 30))
             	Y-Cnt# (1+ Y-Cnt#)
       	);setq
       	(if (<= Y-Cnt# Inc#) (setq Y-Ins (nth Y-Cnt# Y-Pts@)))
     	);progn
   	);if
 	);if
);if
; Erase Troys that are out of limits
(setq Cnt# 0)
(foreach List@ TroyArray@
 	(setq CirEnt^ (nth 0 List@)
       	CirPt1 (nth 1 List@)
       	Radius~ (nth 4 List@)
 	);setq
 	(if (> (distance CenPt CirPt1) CirLimits~)
   	(progn
     	(command "_ERASE" CirEnt^ "")
     	(setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
   	);progn
   	(setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
 	);if
 	(setq Cnt# (1+ Cnt#))
);foreach
(delay 0.15);Speed of Loop
(if (> Y-Cnt# Inc#)(setq Loop nil))
(if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
 	(command "_ZOOM" "_W" (car ViewExtents@)(cadr ViewExtents@))
);if
 );while
 ;-----------------------------------------------------------------------------
 ; Second Loop
 ;-----------------------------------------------------------------------------
 (setq Loop t Move# 0 Ltr# 0 Sevenths# (/ (length Path@) 7) Fire# (1+ Sevenths#))
 (BuildShip: 0 (nth 0 Path@))
 (if (> Path# 2)
(setq MainList@ (entmod (subst (cons 42 -1.0) (assoc 42 MainList@) MainList@)))
 );if
 (while Loop
; Move Ship
(setq Pt1 (nth Move# Path@)
     	Pt2 (nth (1+ Move#) Path@)
     	Ang~ (angle Pt1 Pt2)
);setq
;(command "LINE" Pt1 Pt2 "");Uncomment while debuging
(setq MainList@ (entmod (subst (cons 50 Ang~) (assoc 50 MainList@) MainList@)))
(setq MainList@ (entmod (subst (cons 10 Pt1) (assoc 10 MainList@) MainList@)))
; Fire at Troy Letters
(setq Fire# (1+ Fire#))
(if (= Fire# (fix (* Sevenths# 2.5)))(setq Fire# Sevenths#));First time
(if (= Fire# Sevenths#);Fire in these intervals
 	(progn
   	(setq Fire# 0 Ltr# (1+ Ltr#))
   	(if (member Ltr# (list 1 2 3 4))
     	(progn
       	(setq Pt (nth Ltr# RndLtr@)
             	Ang~ (angle Pt1 Pt)
             	Pt1 (polar Pt1 Ang~ (* Unit~ 2))
             	Pt2 (polar Pt1 Ang~ Unit~)
       	);setq
       	(command "_INSERT" Flame$ Pt1 1 1 (rtd Ang~))
       	(setq FlameArray@ (append FlameArray@ (list (list (entlast) Pt1 Pt2 Ang~))))
     	);progn
   	);if
 	);progn
);if
; Move flame objects
(if FlameArray@
 	(progn
   	(setq Cnt# 0 Nth# nil)
   	(foreach List@ FlameArray@
     	(setq Flame^ (nth 0 List@)
           	Pt1 (nth 1 List@)
           	Pt2 (nth 2 List@)
           	Ang~ (nth 3 List@)
     	);setq
     	(if (or (and (> (car Pt2)(car East))(> (car Pt2)(car Pt1)))
             	(and (< (car Pt2)(car West))(< (car Pt2)(car Pt1)))
             	(and (> (cadr Pt2)(cadr North))(> (cadr Pt2)(cadr Pt1)))
             	(and (< (cadr Pt2)(cadr South))(< (cadr Pt2)(cadr Pt1)))
         	);or
       	(progn
         	(command "_ERASE" Flame^ "")
         	(setq Nth# Cnt#)
       	);progn
       	(progn
         	(command "_MOVE" Flame^ "" Pt1 Pt2)
         	(setq Pt1 Pt2 Pt2 (polar Pt2 Ang~ Unit~))
         	(setq List@ (list Flame^ Pt1 Pt2 Ang~))
         	(setq FlameArray@ (Change_nth Cnt# List@ FlameArray@))
       	);progn
     	);if
     	(setq Cnt# (1+ Cnt#))
   	);foreach
   	(if Nth#
     	(setq FlameArray@ (Delete_nth Nth# FlameArray@))
   	);if
 	);progn
);if
; Check to see if Troy Letters are hit
(if FlameArray@
 	(progn
   	(setq Num# 0)
   	(foreach List@ FlameArray@
     	(setq Ent^ (nth 0 List@)
           	Pt2 (nth 2 List@)
           	Pt nil
     	);setq
     	(cond
       	((<= (distance Pt2 T-Pt) Unit~)
         	(command "_ERASE" T-Ent^ Ent^ "")
         	(setq FlameArray@ (Delete_nth Num# FlameArray@))
         	(setq Pt T-Pt T-Pt SouthWest Color# Color3);Green
       	);case
       	((<= (distance Pt2 R-Pt) Unit~)
         	(command "_ERASE" R-Ent^ Ent^ "")
         	(setq FlameArray@ (Delete_nth Num# FlameArray@))
         	(setq Pt R-Pt R-Pt SouthWest Color# Color4);Cyan
       	);case
       	((<= (distance Pt2 O-Pt) Unit~)
         	(command "_ERASE" O-Ent^ Ent^ "")
         	(setq FlameArray@ (Delete_nth Num# FlameArray@))
         	(setq Pt O-Pt O-Pt SouthWest Color# Color5);Blue
       	);case
       	((<= (distance Pt2 Y-Pt) Unit~)
         	(command "_ERASE" Y-Ent^ Ent^ "")
         	(setq FlameArray@ (Delete_nth Num# FlameArray@))
         	(setq Pt Y-Pt Y-Pt SouthWest Color# Color6);Magenta
       	);case
     	);cond
     	; Explode Letter
     	(if Pt
       	(progn
         	(command "_COLOR" Color#)
         	(setq Dia1~ 0.5 Dia2~ 3 Ang~ (* (GetRnd 6283) 0.001) Inc# 0 Inc1~ 0.125 Inc2~ 0.375)
         	(repeat 10
           	(if (= Inc# 6)(setq Inc1~ -0.125 Inc2~ -0.375))
           	(StarBurst Pt (* Unit~ Dia1~) (* Unit~ Dia2~) (+ (GetRnd 5) 5) Ang~)(delay 0.125)
           	(setq Dia1~ (+ Dia1~ Inc1~) Dia2~ (+ Dia2~ Inc2~))
           	(setq Ang~ (* (GetRnd 6283) 0.001))
           	(command "_ERASE" (entlast) "")
           	(setq Inc# (1+ Inc#))
         	);repeat
         	(command "_COLOR" "_BYLAYER")
       	);progn
     	);if
     	(setq Num# (1+ Num#))
   	);foreach
 	);progn
);if
; Erase Troys that are out of limits
(setq Cnt# 0)
(foreach List@ TroyArray@
 	(setq CirEnt^ (nth 0 List@)
       	CirPt1 (nth 1 List@)
       	Radius~ (nth 4 List@)
 	);setq
 	(if (> (distance CenPt CirPt1) CirLimits~)
   	(progn
     	(command "_ERASE" CirEnt^ "")
     	(setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
   	);progn
   	(setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
 	);if
 	(setq Cnt# (1+ Cnt#))
);foreach
(delay 0.15);Speed of Loop
(setq Move# (1+ Move#))
(if (= Move# (1- (length Path@)))(setq Loop nil))
(if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
 	(command "_ZOOM" "_W" (car ViewExtents@)(cadr ViewExtents@))
);if
 );while
 (setq SS& (ssget "x" (list '(8 . "Troy"))))
 (command "_ERASE" SS& "")
 (princ)
);defun TroyIntro
;-------------------------------------------------------------------------------
; TroyClear - Troy clear function
;-------------------------------------------------------------------------------
(defun TroyClear (/ Block$ Passed SS&)
 (if *TroyTab$* (command "_LAYOUT" "_S" *TroyTab$*))
 (if *Clayer$* (setvar "CLAYER" *Clayer$*))
 (if *Osmode#* (setvar "OSMODE" *Osmode#*))
 (if *TextStyle$* (setvar "TEXTSTYLE" *TextStyle$*))
 (if *TextSize~* (setvar "TEXTSIZE" *TextSize~*))
 (command "_COLOR" "_BYLAYER")
 (if (setq SS& (ssget "_x" (list '(8 . "Troy"))))
(command "_ERASE" SS& "")
 );if
 (setq Block$ (strcat (substr (UniqueName) 1 5) "*"))
 (foreach Item (GetBlockList)
(if (wcmatch Item Block$) (setq Passed t))
 );foreach
 (if Passed (command "_PURGE" "_BL" Block$ "_N"))
 (if (tblsearch "LAYER" "Troy") (command "_PURGE" "_LA" "Troy" "_N"))
 (if (tblsearch "STYLE" "Troy") (command "_PURGE" "_ST" "Troy" "_N"))
 (setq *Clayer$* nil *Osmode#* nil *TextStyle$* nil *TextSize~* nil)
 (PurgeGroups)
 (if *CTab$*
(progn (command "_LAYOUT" "_S" *CTab$*)(setq *CTab$* nil *TroyTab$* nil))
 );if
 (repeat 45 (princ (strcat "\n" (chr 160))))
 (princ)
);defun TroyClear
;-------------------------------------------------------------------------------
; Start of Troy Support Utility Functions
;-------------------------------------------------------------------------------
; acos
; Arguments: 1
;   x = real number between 0 and 1. May be passed as the sum of dividing two
;   	sides of a right triangle.
; Returns: acos of x, the radian degrees between sides of a right triangle
;-------------------------------------------------------------------------------
(defun acos (x)
 (atan (/ (sqrt (- 1 (* x x))) x))
);defun acos
;-------------------------------------------------------------------------------
; asin
; Arguments: 1
;   sine = real number between -1 to 1
; Returns: arcsin of sine
;-------------------------------------------------------------------------------
(defun asin (sine / cosine)
 (setq cosine (sqrt (- 1.0 (expt sine 2))))
 (if (zerop cosine)
(setq cosine 0.000000000000000000000000000001)
 );if
 (atan (/ sine cosine))
);defun asin
;-------------------------------------------------------------------------------
; Center3Pt - Center point of 3 points on a circle
; Arguments: 3
;   Pt1 = First point
;   Pt2 = Second point
;   Pt3 = Third point
; Returns: Center point of 3 points on a circle
;-------------------------------------------------------------------------------
(defun Center3Pt (Pt1 Pt2 Pt3 / Pt Pt4 Pt5 Pt6 Pt7)
 (setq Pt4 (polar Pt1 (angle Pt1 Pt2) (/ (distance Pt1 Pt2) 2.0))
   	Pt5 (polar Pt4 (+ (angle Pt1 Pt2) (* pi 0.5)) 1)
   	Pt6 (polar Pt2 (angle Pt2 Pt3) (/ (distance Pt2 Pt3) 2.0))
   	Pt7 (polar Pt6 (+ (angle Pt2 Pt3) (* pi 0.5)) 1)
   	Pt (inters Pt4 Pt5 Pt6 Pt7 nil)
 );setq
);defun Center3Pt
;-------------------------------------------------------------------------------
; Change_nth - Changes the nth item in a list with a new item value.
; Arguments: 3
;   Num# = Nth number in list to change
;   Value = New item value to change to
;   OldList@ = List to change item value
; Returns: A list with the nth item value changed.
;-------------------------------------------------------------------------------
(defun Change_nth (Num# Value OldList@)
 (if (<= 0 Num# (1- (length OldList@)))
(if (> Num# 0)
 	(cons (car OldList@) (Change_nth (1- Num#) Value (cdr OldList@)))
 	(cons Value (cdr OldList@))
);if
OldList@
 );if
);defun Change_nth
;-------------------------------------------------------------------------------
; delay - time delay function
; Arguments: 1
;   Percent~ - Percentage of *Speed# variable
; Returns: time delay
;-------------------------------------------------------------------------------
(defun delay (Percent~ / Number~)
 (if (not *Speed#) (Speed))
 (repeat (fix (* *Speed# Percent~)) (setq Number~ pi))
 (princ)
);defun delay
;-------------------------------------------------------------------------------
; Delete_nth - Deletes the nth item from a list.
; Arguments: 2
;   Num# = Nth number in list to delete
;   OldList@ = List to delete the nth item
; Returns: A list with the nth item deleted.
;-------------------------------------------------------------------------------
(defun Delete_nth (Num# OldList@)
 (setq Num# (1+ Num#))
 (vl-remove-if '(lambda (x) (zerop (setq Num# (1- Num#)))) OldList@)
);defun Delete_nth
;-------------------------------------------------------------------------------
; dtr - Degrees to Radians.
; Arguments: 1
;   Deg~ = Degrees
; Syntax: (dtr Deg~)
; Returns: Value in radians.
;-------------------------------------------------------------------------------
(defun dtr (Deg~)
 (* pi (/ Deg~ 180.0))
);defun dtr
;-------------------------------------------------------------------------------
; GetBlockList
;-------------------------------------------------------------------------------
(defun GetBlockList (/ BlockList@ Block$ List@)
 (if (setq List@ (tblnext "BLOCK" 't))
(while List@
 	(setq Block$ (cdr (assoc 2 List@)))
 	(if (/= (substr Block$ 1 1) "*")
   	(setq BlockList@ (append BlockList@ (list Block$)))
 	);if
 	(setq List@ (tblnext "BLOCK"))
);while
 );if
 (if BlockList@
(setq BlockList@ (Acad_StrlSort BlockList@))
 );if
 BlockList@
);defun GetBlockList
;-------------------------------------------------------------------------------
; GetRnd - Generates a random number
; Arguments: 1
;   Num# = Maximum random integer number range greater than or less than 0.
; Returns: Random integer number between 0 and Num#.
;-------------------------------------------------------------------------------
(defun GetRnd (Num# / MaxNum# PiDate$ RndNum# Minus Loop)
 (if (or (/= (type Num#) 'INT)(= Num# 0))
(progn
 	(princ "\nSyntax: (GetRnd Num#) Num# = Maximum random integer number range\ngreater than or less than 0.")
 	(exit)
);progn
 );if
 (if (< Num# 0)
(setq MaxNum# (abs (1- Num#)) Minus t)
(setq MaxNum# (1+ Num#))
 );if
 (if (not *RndNum*) (setq *RndNum* 10000))
 (setq Loop t)
 (while Loop
(if (or (null *int*)(> *int* 100))
 	(setq *int* 1)
 	(setq *int* (1+ *int*))
);if
(setq PiDate$ (rtos (* (getvar "cdate") (* pi *int*)) 2 8 ))
(cond
 	((>= MaxNum# 10000)
   	(setq RndNum# (fix (* (atof (substr PiDate$ 13 5)) (* MaxNum# 0.00001))))
 	)
 	((>= MaxNum# 1000)
   	(setq RndNum# (fix (* (atof (substr PiDate$ 14 4)) (* MaxNum# 0.0001))))
 	)
 	((>= MaxNum# 100)
   	(setq RndNum# (fix (* (atof (substr PiDate$ 15 3)) (* MaxNum# 0.001))))
 	)
 	((>= MaxNum# 10)
   	(setq RndNum# (fix (* (atof (substr PiDate$ 16 2)) (* MaxNum# 0.01))))
 	)
 	((>= MaxNum# 1)
   	(setq RndNum# (fix (* (atof (substr PiDate$ 17 1)) (* MaxNum# 0.1))))
 	)
 	(t (setq RndNum# 0))
);cond
(if (/= RndNum# *RndNum*)
 	(setq Loop nil)
);if
 );while
 (setq *RndNum* RndNum#)
 (if Minus
(setq RndNum# (* RndNum# -1))
 );if
 RndNum#
);defun GetRnd
;-------------------------------------------------------------------------------
; Insert_nth - Inserts a new item value into the nth number in list.
; Arguments: 3
;   Num# = Nth number in list to insert item value
;   Value = Item value to insert
;   OldList@ = List to insert item value
; Returns: A list with the new item value inserted.
;-------------------------------------------------------------------------------
(defun Insert_nth (Num# Value OldList@ / Temp@)
 (if (< -1 Num# (1+ (length OldList@)))
(progn
 	(repeat Num#
   	(setq Temp@ (cons (car OldList@) Temp@)
         	OldList@ (cdr OldList@)
   	);setq
 	);repeat
 	(append (reverse Temp@) (list Value) OldList@)
);progn
OldList@
 );if
);defun Insert_nth
;-------------------------------------------------------------------------------
; MirrorPt - Mirror point
; Arguments: 3
;   Pt = Point to mirror
;   BasePt = Base point
;   Angle~ = Mirror angle in radians
; Returns: Returns location of mirrored point
;-------------------------------------------------------------------------------
(defun MirrorPt (Pt BasePt Angle~ / Pt1)
 (if (> Angle~ pi)
(setq Angle~ (- Angle~ pi))
 );if
 (setq Pt1 (inters Pt (polar Pt (+ Angle~ (* pi 0.5)) 1)
               	BasePt (polar BasePt Angle~ 1) nil)
   	Pt1 (polar Pt1 (angle Pt Pt1) (distance Pt Pt1))
 );setq
);defun MirrorPt
;-------------------------------------------------------------------------------
; Move_nth - Moves the nth Num1# item value to the nth Num2# location in a list.
; Arguments: 3
;   Num1# = Nth number in list to move item value
;   Num2# = Nth number in list to move item value of nth Num1# into
;   OldList@ = List to move item values
; Returns: A list with nth item value moved.
;-------------------------------------------------------------------------------
(defun Move_nth (Num1# Num2# OldList@ / Move_nth:)
 (defun Move_nth: (Num1# Num2# OldList@ Nth# Item)
(cond
 	((and (> Nth# Num1#) (> Nth# Num2#))
   	OldList@
 	);case
 	((= Nth# Num1#)
   	(Move_nth: Num1# (1+ Num2#) (cdr OldList@) (1+ Nth#) Item)
 	);case
 	((= Nth# Num2#)
   	(cons Item (Move_nth: (1+ Num1#) Num2# OldList@ (1+ Nth#) Item))
 	);case
 	((cons (car OldList@)
   	(Move_nth: Num1# Num2# (cdr OldList@) (1+ Nth#) Item))
 	);case
);cond
 );defun Move_nth:
 (if (and (/= Num1# Num2#) (<= 0 Num1# (1- (length OldList@))) (<= 0 Num2# (1- (length OldList@))))
(Move_nth: Num1# Num2# OldList@ 0 (nth Num1# OldList@))
OldList@
 );if
);defun Move_nth
;-------------------------------------------------------------------------------
; PurgeGroups - Purge Unused Groups
;-------------------------------------------------------------------------------
(defun PurgeGroups (/ AllGroups@ Cnt# Dictionary^ EntFirst^ EntList@ FirstGroup$
 Group^ GroupName$ Item Previous$ Pt SS& UsedGroups@)
 (setq Pt (polar (getvar "VIEWCTR") (* pi 1.5)(/ (getvar "VIEWSIZE") 2.0)))
 (command "_LINE" Pt (polar Pt (* pi 1.5) 0.00000001) "")
 (setq EntFirst^ (entlast))
 (setq FirstGroup$ (UniqueName))
 (command "_-GROUP" "_C" FirstGroup$ "" EntFirst^ "")
 (setq EntList@ (entget EntFirst^))
 (setq Group^ (cdr (assoc 330 EntList@)))
 (setq EntList@ (entget Group^))
 (setq Dictionary^ (cdr (assoc 330 EntList@)))
 (setq EntList@ (entget Dictionary^))
 (foreach Item EntList@
(if (= (car Item) 3)
 	(if (not (member (cdr Item) AllGroups@))
   	(setq AllGroups@ (append AllGroups@ (list (cdr Item))))
 	);if
);if
 );foreach
 (setq SS& (ssget "_X"))
 (setq Cnt# 0)
 (repeat (sslength SS&)
(setq EntList@ (entget (ssname SS& Cnt#)))
(if (= (cdr (assoc 102 EntList@)) "{ACAD_REACTORS")
 	(progn
   	(setq Group^ (cdr (assoc 330 EntList@)))
   	(setq EntList@ (entget Group^))
   	(if (setq Dictionary^ (cdr (assoc 330 EntList@)))
     	(progn
       	(setq EntList@ (entget Dictionary^))
       	(setq Previous$ "")
       	(foreach Item EntList@
         	(setq Item (cdr Item))
         	(if (equal Item Group^)
           	(setq GroupName$ Previous$)
         	);if
         	(setq Previous$ Item)
       	);foreach
       	(if (not (member GroupName$ UsedGroups@))
         	(setq UsedGroups@ (append UsedGroups@ (list GroupName$)))
       	);if
     	);progn
   	);if
 	);progn
);if
(setq Cnt# (1+ Cnt#))
 );repeat
 (foreach GroupName$ AllGroups@
(if (not (member GroupName$ UsedGroups@))
 	(command "_-GROUP" "_E" GroupName$)
);if
 );foreach
 (command "_-GROUP" "_E" FirstGroup$)
 (command "_ERASE" EntFirst^ "")
 (princ)
);defun PurgeGroups
;-------------------------------------------------------------------------------
; Remove_nths - Removes the RemoveList@ of nths from a list.
; Arguments: 2
;   RemoveList@ = List of nths to remove
;   OldList@ = List to remove the list of nths from
; Returns: A list with the list of nths removed.
;-------------------------------------------------------------------------------
(defun Remove_nths (RemoveList@ OldList@)
 (if (and RemoveList@ OldList@)
(if (zerop (car RemoveList@))
 	(Remove_nths (mapcar '1- (cdr RemoveList@)) (cdr OldList@))
 	(cons (car OldList@) (Remove_nths (mapcar '1- RemoveList@) (cdr OldList@)))
);if
OldList@
 );if
);defun Remove_nths
;-------------------------------------------------------------------------------
; rtd - Radians to degrees
; Arguments: 1
;   Rad~ = radians
; Syntax: (rtd R)
; Returns: value in degrees.
;-------------------------------------------------------------------------------
(defun rtd (Rad~)
 (* 180.0 (/ Rad~ pi))
);defun rtd
;-------------------------------------------------------------------------------
; Speed - Determines the computer processing speed and sets the global variable
; *speed# which may be used in delay loops.
;-------------------------------------------------------------------------------
(defun Speed (/ Cdate~ Cnt# NewSecond# OldSecond#)
 (setq Cdate~ (getvar "CDATE"))
 (setq NewSecond# (fix (* (- (* (- Cdate~ (fix Cdate~)) 100000)(fix (* (- Cdate~ (fix Cdate~)) 100000))) 10)))
 (repeat 2
(setq Cnt# 0)
(setq OldSecond# NewSecond#)
(while (= NewSecond# OldSecond#)
 	(setq Cdate~ (getvar "CDATE"))
 	(setq NewSecond# (fix (* (- (* (- Cdate~ (fix Cdate~)) 100000)(fix (* (- Cdate~ (fix Cdate~)) 100000))) 10)))
 	(setq Cnt# (1+ Cnt#))
);while
 );repeat
 (setq *Speed# Cnt#)
 (princ)
);defun Speed
;-------------------------------------------------------------------------------
; StarBurst - Draws a starburst shape
; Arguments: 5
;   CenPt = Center of starburst
;   Dia1~ = Inside diameter
;   Dia2~ = Outside diameter
;   Sides# = Number of points
;   StartAng~ = Radian angle of first point
; Returns: Draws a starburst shape
;-------------------------------------------------------------------------------
(defun StarBurst (CenPt Dia1~ Dia2~ Sides# StartAng~ / Ang~ Ang1~ List@ List1@
 List2@ List3@ Cnt1# Cnt2# Pt)
 (setq Ang~ (/ pi Sides#))
 (setq Ang1~ (+ StartAng~ (/ Ang~ 2.0)))
 (repeat (* Sides# 2)
(setq Pt (polar CenPt Ang1~ (/ Dia1~ 2.0)))
(setq List1@ (append List1@ (list Pt)))
(setq Ang1~ (+ Ang1~ Ang~))
 );repeat
 (setq Ang1~ (+ StartAng~ Ang~))
 (repeat Sides#
(setq Pt (polar CenPt Ang1~ (/ (+ Dia1~ Dia2~) 4.0)))
(setq List2@ (append List2@ (list Pt)))
(setq Ang1~ (+ Ang1~ (* Ang~ 2)))
 );repeat
 (setq Ang1~ StartAng~)
 (repeat Sides#
(setq Pt (polar CenPt Ang1~ (/ Dia2~ 2.0)))
(setq List3@ (append List3@ (list Pt)))
(setq Ang1~ (+ Ang1~ (* Ang~ 2)))
 );repeat
 (setq Cnt1# 0 Cnt2# 0)
 (repeat Sides#
(setq List@ (append List@ (list (nth Cnt1# List3@))))
(setq List@ (append List@ (list (nth Cnt2# List1@))))
(setq Cnt2# (1+ Cnt2#))
(setq List@ (append List@ (list (nth Cnt1# List2@))))
(setq List@ (append List@ (list (nth Cnt2# List1@))))
(setq Cnt2# (1+ Cnt2#))
(setq Cnt1# (1+ Cnt1#))
 );repeat
 (setq List@ (append List@ (list (nth 0 List3@))))
 (command "_PLINE" (foreach Pt List@ (command Pt)))
 (princ)
);defun StarBurst
;-------------------------------------------------------------------------------
; Switch_nth - Switches the nth Num1# and Num2# item values in a list.
; Arguments: 3
;   Num1# = nth number in list to switch with nth Num2#
;   Num2# = nth number in list to switch with nth Num1#
;   OldList@ = List to switch item values
; Returns: A list with two item values switched.
;-------------------------------------------------------------------------------
(defun Switch_nth (Num1# Num2# OldList@ / Index#)
 (setq Index# -1)
 (if (and (< -1 Num1# (length OldList@)) (< -1 Num2# (length OldList@)))
(mapcar '(lambda (x) (setq Index# (1+ Index#))
 	(cond
   	((= Index# Num2#) (nth Num1# OldList@))
   	((= Index# Num1#) (nth Num2# OldList@))
   	(x)
 	)) OldList@
);mapcar
OldList@
 );if
);defun Switch_nth
;-------------------------------------------------------------------------------
; tan - Tangent of radian degrees
; Arguments: 1
;   radians = Radian degrees
; Returns: Tangent of radian degrees
;-------------------------------------------------------------------------------
(defun tan (radians)
 (/ (sin radians) (cos radians))
);defun tan
;-------------------------------------------------------------------------------
; UniqueName - Creates a unique name for temp blocks and groups
;-------------------------------------------------------------------------------
(defun UniqueName (/ Loop Name$)
 (setq Loop t)
 (while Loop
(setq Name$ (rtos (getvar "CDATE") 2 8))
(setq Name$ (strcat (substr Name$ 4 5)(substr Name$ 10 8)))
(if (/= Name$ *UniqueName$)
 	(setq *UniqueName$ Name$ Loop nil)
);if
 );while
 *UniqueName$
);defun UniqueName
;-------------------------------------------------------------------------------
; ViewExtents
; Returns: List of upper left and lower right points of current view
;-------------------------------------------------------------------------------
(defun ViewExtents (/ A B C D X)
 (setq B (getvar "VIEWSIZE")
   	A (* B (/ (car (getvar "SCREENSIZE")) (cadr (getvar "SCREENSIZE"))))
   	X (trans (getvar "VIEWCTR") 1 2)
   	C (trans (list (- (car X) (/ A 2.0)) (+ (cadr X) (/ B 2.0))) 2 1)
   	D (trans (list (+ (car X) (/ A 2.0)) (- (cadr X) (/ B 2.0))) 2 1)
 );setq
 (list C D)
);defun ViewExtents
;-------------------------------------------------------------------------------
(princ)

lệnh là EXPTXT

 

(defun c:exptxt()
(setq
ss (ssget '((0 . "TEXT")))
fn (getfiled "Ten file: " "" "txt" 1)
f...
>>

lệnh là EXPTXT

 

(defun c:exptxt()
(setq
ss (ssget '((0 . "TEXT")))
fn (getfiled "Ten file: " "" "txt" 1)
f (open fn "w")
lst (ss2ent ss)
)
(foreach e lst
(setq tt (entget e)
p (cdr (assoc 10 tt))
x (rtos (car p))
y (rtos (cadr p))
z (cdr (assoc 1 tt))

)
(write-line (strcat x " " y " " z) f)
)
(close f)
(princ)
)

(defun ss2ent (ss / sodt index lstent)
(setq
sodt (if ss
(sslength ss)
0
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

Bạn ơi, Lisp trên của bạn là chọn thẳng vào text và xuất tọa độ của text đó ra, cao độ cũng chính là text đó. Lisp trên sử dụng được singeltext, không xuất được mutiltext

Nhưng nếu trong trường hợp tọa độ là ở hình tròn và cao độ ghi dang text, stt cũng dạng text thì các bạn xem giúp mình

mình gửi file cad dạng đó và text sử dụng là cả 2 trường hợp:  http://www.mediafire.com/file/k1c7ceejkxjmk39/Xuat+Toa+Do.dwg

Lisp trên bạn thêm giúp mọi người chút nữa với:

khi mở và load lên, sẽ cho mọi người 2 lựa chọn ( tọa độ tại text (1)/tọa độ,stt ngoài text (2)/tọa độ tại text và stt ngoài (3):

nếu gõ 1 sẽ chạy lisp trên ( bạn xem lại giúp, nếu Mutiltext sẽ không nhận được )

Nếu gõ 3 thì lisp trên sẽ thêm phần stt nữa ( khi xuất ra sẽ 1 file txt có stt      x      y       z )

nếu gõ 2 thì sẽ pick chọn lần lượt: text STT => vị trí trích tọa độ => text cao độ ( khi xuất ra sẽ 1 file txt có stt      x      y       z )

<<

Download lisp

Filename: 410197_exptxt.lsp

Đây bạn. Lisp Tue_NV cải tiến chạy theo đúng ý bạn nè :

(defun c:olt()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(while (null (setq ss...
>>

Đây bạn. Lisp Tue_NV cải tiến chạy theo đúng ý bạn nè :

(defun c:olt()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(while (null (setq ss (car(entsel "\n Chon doi tuong offset :")))) 
(Prompt "\n Hay chon lai doi tuong :")
)

(setq po(getpoint "\n phia offset:")) 
(setq kc(getdist "\n khoang cach offset:")) 
(setq n(getint "\n so lan offset:"))
(setq m 0 )
(setq p1 (vlax-curve-getClosestPointTo ss po))
(setq p2 (list (/ (- (* 2 (car p1)) (car po)) 2) (/ (- (* 2 (cadr p1)) (cadr po)) 2) 0.0))

(repeat n
(setq m(+ m 1))
(command "offset" (* m kc) ss po "")
) 

(initget "Y N") ;;;Init keywords
(setq ans (getkword "\n Ban co muon offset sang 2 ben khong?  :")) ;;;Get answer from user
(if (= ans "Y") 
(Progn
(setq m 0 )
(repeat n
(setq m(+ m 1))
(command "offset" (* m kc) ss p2 "")
) 
)
)
(setvar "osmode" oldos)
)

Hy vọng bạn hài lòng.

Cghúc thành công nhé :bigsmile:

 

lisp của bác tuệ thật tuyệt vời. Em nhờ bác Tuệ và các bác viết giùm em lisp offset với yêu cầu sau được kô?

offset đối tượng về 1 phía với các khoảng cách khác nhau mà chỉ cần chọn đối tượng 1 lần, và chỉ cần nhập khoảng cách offset.

lựa chọn offset tuyệt đối so với đối tượng gốc hoặc offset tương đối so với đối tượng sau đó.

<<

Mình đã viết 1 cái rồi nhưng chưa nhớ link, post lại cho bạn. Có thể dùng cho cả Anon Block

;| Change Anonymous Block...
>>

Mình đã viết 1 cái rồi nhưng chưa nhớ link, post lại cho bạn. Có thể dùng cho cả Anon Block

;| Change Anonymous Block to normal with new Name
@ Ketxu 27 - 9 - 2011
|;
(defun c:nb( / blkObj blkName blkNew_Name fn pt)
(vl-load-com)
(defun ST:SS->List-Vla (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
 )
)
(defun change_block(old new)
(foreach blkObj (setq ss (ST:SS->List-Vla (ssget (list (cons 0 "INSERT")(cons 2 old)))))
(vla-put-name blkObj new);;change the name
(vla-update blkObj)
)
)
(grtext -1 "Free Lisp From Cadviet @Ketxu")
(setvar "cmdecho" 0)
(setq
blkObj (vlax-ename->vla-object (car(entsel "\nBlock Source :")))
blkName (vlax-get-property blkObj
(if (vlax-property-available-p blkObj 'EffectiveName) 'EffectiveName 'Name)
 )
blkNew_Name (getstring "\n New Name :")
 fn (strcat (getenv "TEMP") "\\" blkNew_Name ".dwg")
)
(command ".-wblock" fn "_Y" blkName "")
(command "._insert" (strcat blkNew_Name "=" fn) nil )
(if (wcmatch "`*" (substr blkName 1 1))(setq blkName (strcat "`*" (substr blkName 2))))
(change_block blkName blkNew_Name)
(vl-file-delete  fn)
)

 

bạn KETXU cho hỏi mình tạo được tên block mới rồi nhưng kg tìm đc nó nhưng xem trong list block thì vẫn có....làm cách nào để tìm đc cái blog tên mới mà mình mới tạo kg....lisp này rất hay nhưng kg biết cách dùng nên cũng chả biết để làm gì >_<

<<

 

>>

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null ttdangs)(setq ttdangs ""))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
                 (setq txt (strcat ttdangt (cdr (assoc 1 e)) ttdangs))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:BOTTEXT (/ c e ss txt cmde tbdangs tbdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq tbdangt (getreal "\nSo ky tu muon bot phia truoc:")) 
  (setq tbdangs (getreal "\nSo ky tu muon bot phia sau:")) 
  (if (null tbdangt)(setq tbdangt 0))
  (if (null tbdangs)(setq tbdangs 0))
  (setq sotru (+ tbdangt tbdangs))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
(setq sochu (strlen (cdr (assoc 1 e))))
(if (> sochu sotru)
(progn
(setq txt (substr (cdr (assoc 1 e)) (fix (+ 1 tbdangt)) (fix (- sochu tbdangt tbdangs))))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
)
)

        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Lệnh là  THEMTEXT và  BOTTEXT

Hề hề hề,

Mạn phép bác Duy sửa hai dòng code (Prin I) thành (Prin1).

@Bác ĐVH : Bác đổi foreach sang repeat và dùng Index làm chi ạ ^^

Ngoài ra, nếu dùng *Text thì bác cũng cần xử lý trường hợp có Rtext...

>>

@Bác ĐVH : Bác đổi foreach sang repeat và dùng Index làm chi ạ ^^

Ngoài ra, nếu dùng *Text thì bác cũng cần xử lý trường hợp có Rtext ạ

Theo e thì viết kiểu như thế này :

(defun C:HA1(/ lst fn fw i j) ;Doan Van Ha Cadviet.com
(princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")
(setq lst (mapcar 'entget (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION")))))
   	fn (getfiled "Chon file de save" "" "csv" 1)
   	fw (open fn "w") i 0 j 0)
(foreach n lst
(princ
 (cond
  ((wcmatch (cdadr n) "*TEXT")(strcat (acet-dxf 1 n) ";Text" (itoa (setq i (1+ i))) "\n"))  
  ((= (cdadr n) "DIMENSION")(strcat (if (= (acet-dxf 1 n) "")(rtos (acet-dxf 42 n))(acet-dxf 1 n))  ";Dim" (itoa (setq j (1+ j))) "\n"))
 )
  fw
 )
 )
(close fw))

 

P/s thêm : do bác ĐVH chỉ lấy string dạng thô, nên nếu gặp các MText hoặc DimText có Format thì kết quả xuất ra có thể không được như ý (như trường hợp lỗi đầu tiên kia), chứ không phải là true contents nữa ^^

- Vâng, đôi lúc nó vẫn thường ngớ ngẩn như vậy! Khi mang trong đầu ý tưởng text1, text2... thì tự nhiên nghĩ phải repeat+index, hoá ra viết xong thì thấy lãng xẹt, nhưng không sai nên biếng sửa.

- Đúng là "thô" thật.

P/S: có lúc viết 1 hàm mất cả vài ba tiếng, hoá ra nghĩ lại chỉ cần 1 dòng. Lại có lúc đổ công sức để viết 1 hàm... có sẵn nữa chứ. Kể cũng tức mà... vui, Ket ạ!

<<

 

Chỉnh code lại cho bạn đây: 

 

(defun c:dop(/ Tue-dxf Tue-ent-Lpoint cur line dd i...
>>

 

Chỉnh code lại cho bạn đây: 

 

(defun c:dop(/ Tue-dxf Tue-ent-Lpoint cur line dd i sspline)
(vl-load-com)
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun Tue-ent-Lpoint(e / i Lpoint);Tue-dxf
(if (wcmatch (Tue-dxf 0 e) "*POLYLINE")
(progn
  (if (= (type e) 'VLA-OBJECT) (setq e (vlax-vla-object->ename e)))
  (setq i -1)
  (Repeat (if (wcmatch (Tue-dxf 0 e) "*POLYLINE") (fix (1+ (vlax-curve-getEndParam e))) 2)
    (setq Lpoint (append Lpoint (list (vlax-curve-getPointatParam e (setq i (1+ i))))))
  )
)
)
(if (wcmatch (Tue-dxf 0 e) "LINE")
  (setq Lpoint (append Lpoint (list (Tue-dxf 10 e) (Tue-dxf 11 e))))
)
Lpoint
)
  (command "undo" "be")
  (command "ucs" "W")
  (setvar "cmdecho" 0)
(while (and
           (setq i -1) (princ "\n Select Polyline:")
          (setq sspline (ssget '((0 . "*LINE"))))
          (setq line (car (entsel "\nChon line1 :")))
          (setq dd (getpoint "\nChon diem dat :"))
    )
(Repeat (sslength sspline)
  (foreach x (Tue-ent-Lpoint (ssname sspline (setq i (1+ i))))
  (command "._dimlinear"  "_non" x "_non" (vlax-curve-getClosestPointTo line x) "_non" x
             "._dimtedit" (entlast) "_non" (list (car x) (cadr dd) 0.0))
  )
)
)
  (command "ucs" "p")
  (command "undo" "end")
)

Cái này em mò linh tinh thì sửa được lỗi Undo như sau:

)

  (command "ucs" "p")

  (command "undo" "end")

)

)

 

(command "ucs" "p")  (command "undo" "end")))

Chân thành cám ơn Bác Tuệ và diễn đàn nhiều. Chúc các bác luôn mạnh khỏe :)

<<

Bạn phải đọc cho kỹ từng trang chứ?

Lệnh Stext của bác Hoành đây bạn :

(defun c:stext (/ sst lstent egoc pgoc xgoc yht zgoc linespc ee tt)
(if (not...
>>

Bạn phải đọc cho kỹ từng trang chứ?

Lệnh Stext của bác Hoành đây bạn :

(defun c:stext (/ sst lstent egoc pgoc xgoc yht zgoc linespc ee tt)
(if (not tyledong)
(setq tyledong 1.5)
)
(princ "\nSap xep text © CADViet.com")
(setq sst (ssget '((0 . "TEXT")))
lstent (ss2ent sst)
tmp (getreal (strcat "\nVao ty le dong khoang cach dong <"
(rtos tyledong 2 2)
">: "
)
)
tyledong (cond
(tmp tmp)
(t tyledong)
)
lstent (vl-sort lstent
'(lambda (e1 e2)
(> (cadr (cdr (assoc 10 (entget e1))))
(cadr (cdr (assoc 10 (entget e2))))
)
)
)
egoc (car lstent)
lstent (cdr lstent)
pgoc (cdr (assoc 10 (entget egoc)))
xgoc (car pgoc)
yht (cadr pgoc)
zgoc (caddr pgoc)
hgoc (cdr (assoc 40 (entget egoc)))
linespc (* hgoc (+ 1.0 tyledong))

)
(foreach ee lstent
(setq tt (entget ee)
tt (subst (list 10
xgoc
(setq yht (- yht linespc))
zgoc
)
(assoc 10 tt)
tt
)
)
(entmod tt)
(entupd ee)
)
(princ)
)
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (cond
(ss (sslength ss))
(t 0)
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent) 
)
(princ
"\nSTEXT - Sap xep text - free lisp from www.cadviet.com"
)
(vl-load-com)

úi trời.lần này thì ngon rồi.cám ơn bạn nhiều nhé.

<<