H? h? h?,

1/- Có r?t nhi?u lisp ghi ?? d?c ? trên di?n ?àn. hãy ch?u khó tìm ki?m xem có cái nào phù h?p v?i yêu c?u c?a b?n.

2/- B?n nêu yêu c?u nh?ng không có b?n v? minh h?a thì không th? hi?u cái b?n c?n ?? giúp.

3/- Có r?t nhi?u cách ghi ?? d?c: theo %, theo góc ?? .... B?n mu?n cái chi???

4/- B?n nên tìm hi?u k? quy ??nh c?a...

>>

H? h? h?,

1/- Có r?t nhi?u lisp ghi ?? d?c ? trên di?n ?àn. hãy ch?u khó tìm ki?m xem có cái nào phù h?p v?i yêu c?u c?a b?n.

2/- B?n nêu yêu c?u nh?ng không có b?n v? minh h?a thì không th? hi?u cái b?n c?n ?? giúp.

3/- Có r?t nhi?u cách ghi ?? d?c: theo %, theo góc ?? .... B?n mu?n cái chi???

4/- B?n nên tìm hi?u k? quy ??nh c?a di?n ?àn tr??c và trong quá trình tham gia di?n ?àn.

http://www.cadviet.com/forum/topic/13627-do-doc-cua-cac-doan-tren-duong-pl/.

(defun c:gd (/ entpl p1 cao_text sp ep ang dodoc thap_phan)
(vl-load-com)
(setq entpl (entsel "\n Hay chon polyline can ghi do doc")
      entob (vlax-ename->vla-object (car entpl))
)
(setq x (getreal "\n Hay nhap ty le theo truc x: ")
      y (getreal "\n Hay nhap ty le theo truc y: "))
(setq cao_text (getreal "\n Hay nhap chieu cao text: ")
      h (getreal "\n Hay nhap khoang cach tu text toi pline: ")
      i 0
      thap_phan 2
      p1 (cadr entpl)
      ent (car entpl)
      m (vlax-curve-getendparam ent))
(while (< i m)
(setq sp (vlax-curve-getPointatparam ent i)
      ep (vlax-curve-getPointatparam ent (1+ i))
      ang (angle sp ep)
      x1 (car sp)
      y1 (cadr sp)
      x2 (car ep)
      y2 (cadr ep)
      dodoc (* (abs (/ (/ (- y2 y1) y) (/ (- x2 x1) x))) 100)
      dodoc (strcat (rtos dodoc 2 thap_phan) "%"))
(if (< (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.1)))
    (command "_.text" (list (- (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (/ (* ang 180) pi)(strcat " Do doc mai la " dodoc))
    )
    (if (> (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.9)))
    (command "_.text" (list (+ (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (+ 180 (/ (* ang 180) pi)) (strcat " Do doc mai la " dodoc))
    )
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
    (command "_.text" (list (+ (car pt) h) (cadr pt)) cao_text 90 (strcat " Do doc mai la " dodoc))
    )
    )
)
(setq i (1+ i))
)
)

Mình có tìm ???c cái Lisp này trên di?n ?àn ?úng là c?a bác phamthanhbinh nè, nh?ng ch? ghi ???c ?? d?c cho các ?o?n c?a ???ng polyline. Ti?n ?ây c?ng nh? bác s?a cho mình là có th? quét ch?n ???c nhi?u ??i t??ng line m?t lúc nh? ý c?a b?n trên (Lisp này c?a bác ch? ch?n ???c 1 ??i t??ng và là polyline).

V?i c? bác có th? giúp mình m?t lisp l?c t?t c? các line có giá tr? ?? d?c n?m trong m?t kho?ng nh?t ??nh không, c? th? nh? th? này:

- Gõ l?nh, xu?t hi?n yêu c?u nh?p giá tr? c?n trên và c?n d??i.

- Sau ?ó mình quét ch?n nhi?u ??i t??ng line trên b?n v?, nh?ng ???ng line nào có giá tr? ?? d?c (deltaX/deltaY) trong kho?ng trên s? ???c ch?n. Ti?p theo mình x? lý th? nào thì s? do mình.

Cám ?n bác nhi?u l?m ? :">.

<<

Lâu lâu vận động trí óc để tránh Bệnh Alzheimer’s :D :

(defun c:cco (/ oldos css ss p0 p1 p2 a e d)
(defun css (ss p0 p1 a)
((lambda (i / e obj o1 i) (while (setq e (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object e)) (setq o1 (vla-copy obj)) 
(if p0 (vla-move o1 (vlax-3d-point p0) (vlax-3d-point p1)))
(vla-move o1 (vlax-3d-point p1) (vlax-3d-point (polar p1 a d))) )) -1) )
(princ "\n Chon doi tuong can copy") (setq ss...
>>

Lâu lâu vận động trí óc để tránh Bệnh Alzheimer’s :D :

(defun c:cco (/ oldos css ss p0 p1 p2 a e d)
(defun css (ss p0 p1 a)
((lambda (i / e obj o1 i) (while (setq e (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object e)) (setq o1 (vla-copy obj)) 
(if p0 (vla-move o1 (vlax-3d-point p0) (vlax-3d-point p1)))
(vla-move o1 (vlax-3d-point p1) (vlax-3d-point (polar p1 a d))) )) -1) )
(princ "\n Chon doi tuong can copy") (setq ss (ssget) 
p0 (getpoint "\n Chon diem chuan")
p1 (getpoint p0 "\n Chon diem goc") 
p2 (getpoint p1 "\n Chon diem dinh huong copy") 
a (angle p1 p2) e (entlast))
(while (setq d (getdist "\n Nhap khoang cach can copy tiep theo: "))
(css ss p0 p1 a) (setq ss (ssadd))
(while (setq e (entnext e)) (setq ss (ssadd e ss))) 
(setq p0 nil e (entlast)) )
(princ))

Lỗi là do hàm MakeText chưa được load _ mình cũng không hiểu vì sao :D :D :D

>>> Xử lý: Bạn Cut đoạn code định nghĩa hàm MakeText >>> paste xuống cuối cùng nhé !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/154743-nha-via-t-lisp-ta-a-a-theo-file-a-nh-kem/
(defun c:EC( / i p point lst key base_pnt last_pnt fn pw)
;Export...
>>

Lỗi là do hàm MakeText chưa được load _ mình cũng không hiểu vì sao :D :D :D

>>> Xử lý: Bạn Cut đoạn code định nghĩa hàm MakeText >>> paste xuống cuối cùng nhé !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/154743-nha-via-t-lisp-ta-a-a-theo-file-a-nh-kem/
(defun c:EC( / i p point lst key base_pnt last_pnt fn pw)
;Export Coordinates
(setq i 1)
(while (setq p (getpoint "\nPick Point: "))
	(setq point p)
	(MakeText (itoa i) 2.5 0 "L" nil nil 1 nil)
	(setq p (list i (car p) (cadr p))
	i (1+ i)
	lst (cons p lst)))
(if (> (length lst) 2)
	(progn
		(initget "Cad Excel cadAndexcel")
		(setq key (NGT key "Cad" getkword "Enter an option [Cad/Excel/cad_And_excel]"))
		(cond
			((wcmatch key "Cad") 
				(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
				(setq base_pnt (getpoint "\nDiem chen: "))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
			;;Xong tieu de
				(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
				(setq last_pnt (cdr (last lst)))
			;;Xong dong 1
				(foreach p (cdr (reverse lst))
					(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
					(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 3) nil)
					(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 3) nil)
					(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
					(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3) nil)
				)
			;;Xong cac diem giua
				(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 3) nil)
			;;Xong lap lai dong 1 + k/cach khep
			)
			((wcmatch key "Excel")
				(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 				(setq pw (open fn "w"))
				(write-line "STT,X,Y,K/cach (m)" pw)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3)) pw)
				(setq last_pnt (cdr (last lst)))
 				(foreach p (cdr (reverse lst))
  				(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 3) "," (rtos (last p) 2 3) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3)) pw)
				)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3) "," (rtos (distance last_pnt (cdr (last lst))) 2 3)) pw)
 				(close pw)
			)
			(t
				(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
				(setq base_pnt (getpoint "\nDiem chen: "))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
			;;Xong tieu de
				(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
				(setq last_pnt (cdr (last lst)))
			;;Xong dong 1
				(foreach p (cdr (reverse lst))
					(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
					(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 3) nil)
					(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 3) nil)
					(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
					(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3) nil)
				)
			;;Xong cac diem giua
				(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
				(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 3) nil)
			;;Xong lap lai dong 1 + k/cach khep
			;;Xong chen bang trong cad
				(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 				(setq pw (open fn "w"))
				(write-line "STT,X,Y,K/cach (m)" pw)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3)) pw)
				(setq last_pnt (cdr (last lst)))
 				(foreach p (cdr (reverse lst))
  				(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 3) "," (rtos (last p) 2 3) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3)) pw)
				)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3) "," (rtos (distance last_pnt (cdr (last lst))) 2 3)) pw)
 				(close pw)
			)
		)
	)
	(princ "\n***** Phai pick >2 diem ! ***")
)
(princ)
)
;;;End main
;===============================================================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;=====================
(defun H:Creat_Cel+Data (base_pnt L1 L2 L3 L4 celheight celwidth offset textheight justify string Ang / pnt2 pnt3 pnt4 justify point)

;=================================
(defun MakeLine (PT1 PT2 Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "LINE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))								  
				(cons 48 (if LTScale LTScale 1))									
				(cons 62 (if Color Color 256))									
				(cons 10 PT1)	(cons 11 PT2)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================
(if (null celheight) (setq celheight (+ textheight (* 2 offset))))
(setq	pnt2 (polar base_pnt 0 celwidth)
		pnt3 (polar pnt2 (* 1.5 pi) celheight)
		pnt4 (polar pnt3 pi celwidth)
		)
(if justify (setq justify (strcase justify)))
(cond
	((wcmatch justify "C,BC") (setq point (polar (polar pnt4 (* 0.5 pi) offset) 0 (* 0.5 celwidth))))
	((wcmatch justify "R,BR") (setq point (polar pnt3 (* 0.75 pi) (* offset (sqrt 2)))))
	((wcmatch justify "M") (setq point (polar base_pnt 0 (* 0.5 celwidth))))
	((wcmatch justify "MC") (setq point (polar (polar pnt4 (* 0.5 pi) (* 0.5 celheight)) 0 (* 0.5 celwidth))))
	((wcmatch justify "TL")	(setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 offset)))
	((wcmatch justify "TC")	(setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 (* 0.5 celheight))))
	((wcmatch justify "TR")	(setq point (polar pnt2 (* 1.25 pi) (* offset (sqrt 2)))))
	((wcmatch justify "ML")	(setq point (polar (polar base_pnt (* 1.5 pi) (* 0.5 celheight)) 0 offset)))
	((wcmatch justify "MR")	(setq point (polar (polar pnt2 (* 1.5 pi) (* 0.5 celheight)) pi offset)))
	(t (setq point (polar pnt4 (* 0.25 pi) (* offset (sqrt 2)))))
)
(if L1 (MakeLine pnt4 pnt3 nil nil nil nil nil))
(if L2 (MakeLine pnt3 pnt2 nil nil nil nil nil))
(if L3 (MakeLine base_pnt pnt2 nil nil nil nil nil))
(if L4 (MakeLine pnt4 base_pnt nil nil nil nil nil))
(if string (MakeText string textheight Ang justify nil nil nil nil))
)
;===================================
(defun MakeText (string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(cons 50 (if Ang Ang 0))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				;justify (strcase justify)
				)	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================

p/s: Tiện thể, có bác nào ngang qua cho em hỏi: Vì sao khi "bỏ" hàm MakeText vào trong hàm H:Creat_Cel+Data (mục đích để định nghĩa lại nó mỗi khi gọi hàm H:Creat_Cel+Data tránh sai sót) và đã không thiết lập nó là biến cục bộ thì cad không load được hàm MakeText.

Phải chăng là do mình đã để ngõ tham số point trong đó.

Trước hết bạn phải tải các file doslib...arx vào thư mục support hoạc bất kỳ thư mục nào mà bạn đã add trong "support file search path. Tải các file doslib tại đây: http://www.en.na.mcneel.com/doslib.htm

Đây là lisp Thiep thêm arxload:

>>

Trước hết bạn phải tải các file doslib...arx vào thư mục support hoạc bất kỳ thư mục nào mà bạn đã add trong "support file search path. Tải các file doslib tại đây: http://www.en.na.mcneel.com/doslib.htm

Đây là lisp Thiep thêm arxload:

(cond ((eq (getvar "acadver") "19.0s (LMS Tech)")
(arxload "doslib19")
      )
      ((or (eq (getvar "acadver") "18.2s (LMS Tech)")
  (eq (getvar "acadver") "18.1s (LMS Tech)")
  (eq (getvar "acadver") "18.0s (LMS Tech)")
       )
(arxload "doslib18")
      )
      ((or (eq (getvar "acadver") "17.2s (LMS Tech)")
  (eq (getvar "acadver") "17.1s (LMS Tech)")
  (eq (getvar "acadver") "17.0s (LMS Tech)")
       )
(arxload "doslib17")
      )
)
(defun c:cltf (/ lsp fas lst)
    (setq
        lsp (dos_getdir "Browse for folder" " " "Select a folder as source" t)
    )
    (setq fas (dos_getdir "Browse for folder"
                          " "
                          "Select a folder as destination"
                          t
              )
    )
    (setq lst (vl-directory-files lsp "*.lsp" 1))
    (if lst
        (progn
            (foreach x lst
                (vlisp-compile 'st
                               (strcat lsp x)
                               (strcat fas (substr x 1 (- (strlen x) 4)) ".fas")
                )
            )                                     ; foreach
        )                                         ; progn
        (alert "There is not contained file")
    )                                             ; if
    (princ)
)  

Tuy nhiên, lisp trên chỉ compiler mỗi một file *.lsp thành 1 file *.fas. Chưa biết làm sao compiler nhiều file thành 1 file được. (Nếu làm trong VLISP thì ok rồi)

@Namgiang:

1. Khoảng cách này bạn đã không yêu cầu từ đầu >>> Ngại sửa lắm, nhưng đã sửa theo ý bạn.

2. Text chữ thì canh giữa, số thì canh Right (k/cach canh giữa là vì mình nhác, nếu không đã canh R) >>>> Mình bảo lưu, ko sửa.

3. Bạn cài đặt dấu thập phân cho Excel là đấu chấm "." nhé !

4. Có lẽ bạn đã không đặt lại...

@Namgiang:

1. Khoảng cách này bạn đã không yêu cầu từ đầu >>> Ngại sửa lắm, nhưng đã sửa theo ý bạn.

2. Text chữ thì canh giữa, số thì canh Right (k/cach canh giữa là vì mình nhác, nếu không đã canh R) >>>> Mình bảo lưu, ko sửa.

3. Bạn cài đặt dấu thập phân cho Excel là đấu chấm "." nhé !

4. Có lẽ bạn đã không đặt lại tên file nên xuất file trùng tên vì trước đó bạn đã thử cho lựa chọn Excel

;lisp pick diem => xuat toa do thua ra cad, excel
;;So diem pick phai >2
(defun c:EC( / i p point lst key base_pnt last_pnt fn pw)
;Export Coordinates
;===================================
(defun MakeText (string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(cons 50 (if Ang Ang 0))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				;justify (strcase justify)
				)	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================
(setq i 1)
(while (setq p (getpoint "\nPick Point: "))
	(setq point p)
	(MakeText (itoa i) 2.5 0 "L" nil nil 1 nil)
	(setq p (list i (car p) (cadr p))
	i (1+ i)
	lst (cons p lst)))
(if (> (length lst) 2)
	(progn
		(setq #sole (NGT #sole 3 getint "So thap phan"))
		(initget "Cad Excel cadAndexcel")
		(setq key (NGT key "Cad" getkword "Enter an option [Cad/Excel/cadAndexcel]"))
		(cond
			((wcmatch key "Cad") 
				(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
				(setq base_pnt (getpoint "\nDiem chen: "))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
			;;Xong tieu de
				(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
				(setq last_pnt (cdr (last lst)))
			;;Xong dong 1
				(foreach p (cdr (reverse lst))
					(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
					(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 #sole) nil)
					(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 #sole) nil)
					(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
					(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 #sole) nil)
				)
			;;Xong cac diem giua
				(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 #sole) nil)
			;;Xong lap lai dong 1 + k/cach khep
			)
			((wcmatch key "Excel")
				(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 				(setq pw (open fn "w"))
				(write-line "STT,X,Y,K/cach (m)" pw)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 #sole) "," (rtos (last (last lst)) 2 #sole)) pw)
				(setq last_pnt (cdr (last lst)))
 				(foreach p (cdr (reverse lst))
  				(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 #sole) "," (rtos (last p) 2 #sole) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 #sole)) pw)
				)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 #sole) "," (rtos (last (last lst)) 2 #sole) "," (rtos (distance last_pnt (cdr (last lst))) 2 #sole)) pw)
 				(close pw)
			)
			(t
				(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
				(setq base_pnt (getpoint "\nDiem chen: "))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
			;;Xong tieu de
				(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
				(setq last_pnt (cdr (last lst)))
			;;Xong dong 1
				(foreach p (cdr (reverse lst))
					(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
					(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 #sole) nil)
					(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
					(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 #sole) nil)
					(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
					(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 #sole) nil)
				)
			;;Xong cac diem giua
				(setq base_pnt (polar (polar base_pnt pi (* 20 #textheight)) (* 1.5 pi) (* 2 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 4 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
				(setq base_pnt (polar base_pnt 0 (* 4 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 8 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 #sole) nil)
				(setq base_pnt (polar base_pnt 0 (* 8 #textheight)))
				(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 7 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 #sole) nil)
			;;Xong lap lai dong 1 + k/cach khep
			;;Xong chen bang trong cad
				(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 				(setq pw (open fn "w"))
				(write-line "STT,X,Y,K/cach (m)" pw)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 #sole) "," (rtos (last (last lst)) 2 #sole)) pw)
				(setq last_pnt (cdr (last lst)))
 				(foreach p (cdr (reverse lst))
  				(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 #sole) "," (rtos (last p) 2 #sole) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 #sole)) pw)
				)
				(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 #sole) "," (rtos (last (last lst)) 2 #sole) "," (rtos (distance last_pnt (cdr (last lst))) 2 #sole)) pw)
 				(close pw)
			)
		)
	)
	(princ "\n***** Phai pick >2 diem ! ***")
)
(princ)
)
;;;End main
;===============================================================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;=====================
(defun H:Creat_Cel+Data (base_pnt L1 L2 L3 L4 celheight celwidth offset textheight justify string Ang / pnt2 pnt3 pnt4 justify point)

;=================================
(defun MakeLine (PT1 PT2 Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "LINE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))								  
				(cons 48 (if LTScale LTScale 1))									
				(cons 62 (if Color Color 256))									
				(cons 10 PT1)	(cons 11 PT2)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================
(if (null celheight) (setq celheight (+ textheight (* 2 offset))))
(setq	pnt2 (polar base_pnt 0 celwidth)
		pnt3 (polar pnt2 (* 1.5 pi) celheight)
		pnt4 (polar pnt3 pi celwidth)
		)
(if justify (setq justify (strcase justify)))
(cond
	((wcmatch justify "C,BC") (setq point (polar (polar pnt4 (* 0.5 pi) offset) 0 (* 0.5 celwidth))))
	((wcmatch justify "R,BR") (setq point (polar pnt3 (* 0.75 pi) (* offset (sqrt 2)))))
	((wcmatch justify "M") (setq point (polar base_pnt 0 (* 0.5 celwidth))))
	((wcmatch justify "MC") (setq point (polar (polar pnt4 (* 0.5 pi) (* 0.5 celheight)) 0 (* 0.5 celwidth))))
	((wcmatch justify "TL")	(setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 offset)))
	((wcmatch justify "TC")	(setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 (* 0.5 celheight))))
	((wcmatch justify "TR")	(setq point (polar pnt2 (* 1.25 pi) (* offset (sqrt 2)))))
	((wcmatch justify "ML")	(setq point (polar (polar base_pnt (* 1.5 pi) (* 0.5 celheight)) 0 offset)))
	((wcmatch justify "MR")	(setq point (polar (polar pnt2 (* 1.5 pi) (* 0.5 celheight)) pi offset)))
	(t (setq point (polar pnt4 (* 0.25 pi) (* offset (sqrt 2)))))
)
(if L1 (MakeLine pnt4 pnt3 nil nil nil nil nil))
(if L2 (MakeLine pnt3 pnt2 nil nil nil nil nil))
(if L3 (MakeLine base_pnt pnt2 nil nil nil nil nil))
(if L4 (MakeLine pnt4 base_pnt nil nil nil nil nil))
(if string (MakeText string textheight Ang justify nil nil nil nil))
)

Dùng cái này xem.

;Doan Van Ha - CADViet.com - Ngay 23/11/2015
;Muc dich: Chon cac doi tuong Line nam giua 2 gioi han ve Dy/Dx.
(defun C:HA( / duoi tren ss lst)
 (if
  (and
   (not (initget 1)) (setq duoi (getreal "\nNhap gioi han duoi: "))
   (not (initget 1)) (setq tren (getreal "\nNhap gioi han tren: "))
   (princ "\nChon cac doi tuong Line...")
   (setq ss (ssget '((0 . "Line"))) ss1...
>>

Dùng cái này xem.

;Doan Van Ha - CADViet.com - Ngay 23/11/2015
;Muc dich: Chon cac doi tuong Line nam giua 2 gioi han ve Dy/Dx.
(defun C:HA( / duoi tren ss lst)
 (if
  (and
   (not (initget 1)) (setq duoi (getreal "\nNhap gioi han duoi: "))
   (not (initget 1)) (setq tren (getreal "\nNhap gioi han tren: "))
   (princ "\nChon cac doi tuong Line...")
   (setq ss (ssget '((0 . "Line"))) ss1 (ssadd)))
  (progn  
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lst (entget ent))
    (if
     (>= tren (/ (- (caddr (assoc 10 lst)) (caddr (assoc 11 lst))) (- (cadr (assoc 10 lst)) (cadr (assoc 11 lst)))) duoi)
     (setq ss1 (ssadd ent ss1))))
   (sssetfirst nil ss1))))

Pro nào có lisp pick tọa độ như hình cho emm xin với.

Bạn dùng tạm cái này xem sao^^

Cái này,lúc trước mình sửa lại cho 1 bạn trên cadviet ^^ 

Lisp này không phải chính chủ nhé!

(prompt "\n -...

Pro nào có lisp pick tọa độ như hình cho emm xin với.

Bạn dùng tạm cái này xem sao^^

Cái này,lúc trước mình sửa lại cho 1 bạn trên cadviet ^^ 

Lisp này không phải chính chủ nhé!

(prompt "\n - THONG KE TOA DO")
(prompt "\nEdit : @ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN\n")
;;;;;;----------------------------------------------
(defun C:TTD (/ angd angr bit c caot1 d1 d2 di dt dx dy h i k kc
l1 l11 l2 l22 lacol lc n om p1 p11 p2 p22 p3 p33 p4 pt
pt3 pt4 pt5 ptb ptc ptd ptx pty rc stt tapx tapy tb tmp tstt tx ty
x xx y yy
)
(setvar "cmdecho" 0)
(command "Undo" "Begin")
(setq osm (getvar "osmode"))
(if (not *h*)
(setq *h* 1)
)
(setq caot1 (getreal (strcat "\nCao text < " (rtos *h* 2 2) " >:")))
(if caot1
(setq *h* caot1)
(setq caot1 *h*)
)
(setq tapx '()
tapy '()
stt '()
)
(setvar "osmode" 125)
(setq lacol (getvar "CEColor")
i 1
)
(While
(setq D1 (getpoint (strcat "\nPick \U+0111i\U+1EC3m th\U+1EE9 " (rtos i 2 0) " :")))
(Progn
(setq DX (getpoint
(strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t Text c\U+1EE7a n\U+00FAt th\U+1EE9 "
(rtos i 2 0)
" :"
)
D1
)
DY (getpoint "\H\U+01B0\U+1EDBng g\U+00F3c nghi\U+00EAng c\U+1EE7a Text :" Dx)
angr (angle Dx Dy)
)
(setq angd (/ (* 180 angr) pi)
x (rtos (car D1) 2 0)
y (rtos (cadr D1) 2 0)
TX (strcat "X:" (rtos (Car D1) 2 0))
TY (strcat "Y:" (rtos (Cadr D1) 2 0))
tapx (append tapx (list x))
tapy (append tapy (list y))
stt (append stt (list i))
)
(setvar "osmode" 0)
(if (>= (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 caot1)))
(command "text" "BL" D2 caot1 angd tX)
(setq TB (textbox (entget (entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 caot1)))
pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 caot1))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 caot1))
)
;;setq
(command "text" "F" PT4 PT5 caot1 ty "pline" D1 DX PT3 "")
;;command
(setvar "CECOLOR" lacol)
)
;;progn
)
;;if
(if (< (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 caot1)))
(command "text" "BR" D2 caot1 (+ angd 180) tx)
(setq TB (textbox (entget (entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 caot1)))
pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 caot1))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 caot1))
)
;;setq
(command "text" "F" PT5 PT4 caot1 TY "pline" D1 DX PT3 "")
;;command
(setvar "CECOLOR" lacol)
)
;;progn
)
(setvar "osmode" 125)
;;if
)
;;progn
(setq i (+ i 1))
)
;;if
(setq bit (cond (bit)
("Yes")
)
)
(initget "Yes No")
(setq Tmp (strcat "\nXuat b\U+1EA3ng th\U+1ED1ng k\U+00EA t\U+1ECDa \U+0111\U+1ED9 ? <"
bit
">: "
)
bit (cond ((getkword Tmp))
(bit)
)
)
(if (eq bit "Yes")
(progn
(setq di (- di (* 0.4 caot1))
kc (* 2 di)
PT (getpoint "\nCh\U+1ECDn v\U+1ECB tr\U+00ED \U+0111\U+1EB7t b\U+1EA3ng :")
PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))
p1 (list (car PT) (+ (cadr PT) (* 2 caot1)))
p2 (list (car PTC) (+ (cadr PTC) (* 2 caot1)))
p3 (list (car p1) (+ (cadr p1) (* 2 caot1)))
p4 (list (car p2) (+ (cadr p2) (* 2 caot1)))
PTD (list (+ (/ di 2) (car PT)) (+ caot1 (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 caot1) (car PTD)) (cadr PTD))
PTY (list (+ kc (- caot1 caot1 caot1 caot1) (car PTX)) (cadr PTX))
p11 (list (+ (/ di 2) (car p1)) (+ (* 1.1 caot1) (cadr p1)))
p22 (list (+ di (/ di 2) (- 0 caot1) (car p11)) (- (cadr p11) (* 0.1 caot1)))
p33 (list (+ kc (- caot1 caot1 caot1 caot1) (car p22)) (cadr p22))
L1 (list (+ di (car p3)) (cadr p3))
L2 (list (+ kc (- 0 caot1 caot1) (car L1)) (cadr L1))
PTB (list (+ (- (* 2 caot1)) (* 0.5 (+ (* 2 kc) di)) (car PT))
(+ (cadr P3) (* 1.8 caot1))
)
n (length tapx)
k 0
)
;;setq
(setvar "osmode" 0)
(command "CECOLOR"
3
"line"
p1
p2
""
"line"
p3
p4
""
"CECOLOR"
2
"text"
"m"
p11
caot1
0
"STT"
"text"
"m"
p22
caot1
0
"Toa do X"
"text"
"m"
p33
caot1
0
"Toa do Y"
"text"
"m"
pTB
(* 1.3 caot1)
0
"Bang thong ke toa do diem"
)
(while (< k n)
(setq xx (nth k tapx)
yy (nth k tapy)
tstt (nth k stt)
)
(command "CECOLOR" 2 "text" "m" PTD caot1 0 tstt "text" "m"
PTX caot1 0 xx "text" "m" PTY caot1 0 yy "CECOLOR"
3 "line" PT PTC ""
)
(setq PT (list (car PT) (- (cadr PT) (* 2 caot1)))
PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))
PTD (list (+ (/ di 2) (car PT)) (+ caot1 (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 caot1) (car PTD)) (cadr PTD))
PTY (list (+ kc (- caot1 caot1 caot1 caot1) (car PTX)) (cadr PTX))
k (+ 1 k)
)
;;setq
)
;;while
(if (= k n)
(setq PT (list (car PT) (+ (cadr PT) (* 2 caot1)))
PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))
L11 (list (+ di (car PT)) (cadr PT))
L22 (list (+ kc (- 0 caot1 caot1) (car L11)) (cadr L11))
)
;;setq
)
;;if
(command "CECOLOR" 3 "line" p3 PT "" "line" p4 PTC "" "line" L1 L11 "" "line" L2 L22 "")
)
;;progn
)
;;if
(setvar "CECOLOR" lacol)
(setvar "osmode" om)
(prompt "\n\n")
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
)
;;DONG toa do

Chúc thành công !

Có lẽ do yêu cầu trước hơi nhiều nên các bác ngại. Nên em xin đôi yêu cầu cho ngắn:

+ Viết thành lisp chương trình này để em có thể chỉnh sửa.

+ Tọa độ đối chiếu (gốc), là bất kỳ không phải là +0.00.

+ Tọa độ gốc lấy theo text của gốc. Nghĩa là mình chỉ cần thay đổi text của tọa độ gốc thì tọa độ con nhảy theo text đó.

Lệnh chạy chương...

Có lẽ do yêu cầu trước hơi nhiều nên các bác ngại. Nên em xin đôi yêu cầu cho ngắn:

+ Viết thành lisp chương trình này để em có thể chỉnh sửa.

+ Tọa độ đối chiếu (gốc), là bất kỳ không phải là +0.00.

+ Tọa độ gốc lấy theo text của gốc. Nghĩa là mình chỉ cần thay đổi text của tọa độ gốc thì tọa độ con nhảy theo text đó.

Lệnh chạy chương trình: CD1, update bằng RE

http://www.cadviet.com/link/?f=upfiles/4/141736_cotcaodo_2.zip&w=152

Hình chường trình:

Mong các bác giúp đỡ!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/155015-lisp-ghi-cha-ta-a-a-ta-ng-ia-m-khi-pick/
(prompt "\n - THONG KE TOA DO")

(prompt "\nEdit : @ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN\n")

;;;;;;----------------------------------------------

(defun C:TTD (/ angd angr bit c caot1 d1 d2 di dt dx dy h i k kc

l1 l11 l2 l22 lacol lc n om p1 p11 p2 p22 p3 p33 p4 pt

pt3 pt4 pt5 ptb...

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/155015-lisp-ghi-cha-ta-a-a-ta-ng-ia-m-khi-pick/
(prompt "\n - THONG KE TOA DO")

(prompt "\nEdit : @ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN\n")

;;;;;;----------------------------------------------

(defun C:TTD (/ angd angr bit c caot1 d1 d2 di dt dx dy h i k kc

l1 l11 l2 l22 lacol lc n om p1 p11 p2 p22 p3 p33 p4 pt

pt3 pt4 pt5 ptb ptc ptd ptx pty rc stt tapx tapy tb tmp tstt tx ty

x xx y yy

)

(setvar "cmdecho" 0)

(command "Undo" "Begin")

(setq osm (getvar "osmode"))

(if (not *h*)

(setq *h* 1)

)

(setq caot1 (getreal (strcat "\nCao text < " (rtos *h* 2 2) " >:")))

(if caot1

(setq *h* caot1)

(setq caot1 *h*)

)

(setq tapx '()

tapy '()

stt '()

)

(setvar "osmode" 125)

(setq lacol (getvar "CEColor")

i 1

)

(While

(setq D1 (getpoint (strcat "\nPick \U+0111i\U+1EC3m th\U+1EE9 " (rtos i 2 0) " :")))

(command "circle" D1 (* 0.2 caot1) "")

(Progn

(setq DX (getpoint

(strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t Text c\U+1EE7a n\U+00FAt th\U+1EE9 "

(rtos i 2 0)

" :"

)

D1

)

DY (getpoint "\H\U+01B0\U+1EDBng g\U+00F3c nghi\U+00EAng c\U+1EE7a Text :" Dx)

angr (angle Dx Dy)

)

(setq angd (/ (* 180 angr) pi)

x (rtos (car D1) 2 0)

y (rtos (cadr D1) 2 0)

TX (strcat "X:" (rtos (Car D1) 2 0))

TY (strcat "Y:" (rtos (Cadr D1) 2 0))

tapx (append tapx (list x))

tapy (append tapy (list y))

stt (append stt (list i))

)

(setvar "osmode" 0)

(if (>= (car DY) (car DX))

(progn

(setq D2 (polar Dx angr (* 0.7 caot1)))

(command "text" "BL" D2 caot1 angd tX)

(setq TB (textbox (entget (entlast)))

LC (car TB)

RC (cadr TB)

di (distance LC RC)

PT3 (polar D2 angr (+ di (* 0.4 caot1)))

pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 caot1))

pt5 (polar pt4 angr di)

C (polar PT3 0 (* 1.5 caot1))

)

;;setq

(command "text" "F" PT4 PT5 caot1 ty "pline" D1 DX PT3 "")

;;command

(setvar "CECOLOR" lacol)

)

;;progn

)

;;if

(if (< (car DY) (car DX))

(progn

(setq D2 (polar Dx angr (* 0.7 caot1)))

(command "text" "BR" D2 caot1 (+ angd 180) tx)

(setq TB (textbox (entget (entlast)))

LC (car TB)

RC (cadr TB)

di (distance LC RC)

PT3 (polar D2 angr (+ di (* 0.4 caot1)))

pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 caot1))

pt5 (polar pt4 angr di)

C (polar PT3 0 (* 1.5 caot1))

)

;;setq

(command "text" "F" PT5 PT4 caot1 TY "pline" D1 DX PT3 "")

;;command

(setvar "CECOLOR" lacol)

)

;;progn

)

(setvar "osmode" 125)

;;if

)

;;progn

(setq i (+ i 1))

)

;;if

(setq bit (cond (bit)

("Yes")

)

)

(initget "Yes No")

(setq Tmp (strcat "\nXuat b\U+1EA3ng th\U+1ED1ng k\U+00EA t\U+1ECDa \U+0111\U+1ED9 ? <"

bit

">: "

)

bit (cond ((getkword Tmp))

(bit)

)

)

(if (eq bit "Yes")

(progn

(setq di (- di (* 0.4 caot1))

kc (* 2 di)

PT (getpoint "\nCh\U+1ECDn v\U+1ECB tr\U+00ED \U+0111\U+1EB7t b\U+1EA3ng :")

PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))

p1 (list (car PT) (+ (cadr PT) (* 2 caot1)))

p2 (list (car PTC) (+ (cadr PTC) (* 2 caot1)))

p3 (list (car p1) (+ (cadr p1) (* 2 caot1)))

p4 (list (car p2) (+ (cadr p2) (* 2 caot1)))

PTD (list (+ (/ di 2) (car PT)) (+ caot1 (cadr PT)))

PTX (list (+ di (/ di 2) (- 0 caot1) (car PTD)) (cadr PTD))

PTY (list (+ kc (- caot1 caot1 caot1 caot1) (car PTX)) (cadr PTX))

p11 (list (+ (/ di 2) (car p1)) (+ (* 1.1 caot1) (cadr p1)))

p22 (list (+ di (/ di 2) (- 0 caot1) (car p11)) (- (cadr p11) (* 0.1 caot1)))

p33 (list (+ kc (- caot1 caot1 caot1 caot1) (car p22)) (cadr p22))

L1 (list (+ di (car p3)) (cadr p3))

L2 (list (+ kc (- 0 caot1 caot1) (car L1)) (cadr L1))

PTB (list (+ (- (* 2 caot1)) (* 0.5 (+ (* 2 kc) di)) (car PT))

(+ (cadr P3) (* 1.8 caot1))

)

n (length tapx)

k 0

)

;;setq

(setvar "osmode" 0)

(command "CECOLOR"

3

"line"

p1

p2

""

"line"

p3

p4

""

"CECOLOR"

2

"text"

"m"

p11

caot1

0

"STT"

"text"

"m"

p22

caot1

0

"Toa do X"

"text"

"m"

p33

caot1

0

"Toa do Y"

"text"

"m"

pTB

(* 1.3 caot1)

0

"Bang thong ke toa do diem"

)

(while (< k n)

(setq xx (nth k tapx)

yy (nth k tapy)

tstt (nth k stt)

)

(command "CECOLOR" 2 "text" "m" PTD caot1 0 tstt "text" "m"

PTX caot1 0 xx "text" "m" PTY caot1 0 yy "CECOLOR"

3 "line" PT PTC ""

)

(setq PT (list (car PT) (- (cadr PT) (* 2 caot1)))

PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))

PTD (list (+ (/ di 2) (car PT)) (+ caot1 (cadr PT)))

PTX (list (+ di (/ di 2) (- 0 caot1) (car PTD)) (cadr PTD))

PTY (list (+ kc (- caot1 caot1 caot1 caot1) (car PTX)) (cadr PTX))

k (+ 1 k)

)

;;setq

)

;;while

(if (= k n)

(setq PT (list (car PT) (+ (cadr PT) (* 2 caot1)))

PTC (list (+ (* 2 kc) (- di caot1 caot1 caot1 caot1) (car PT)) (cadr PT))

L11 (list (+ di (car PT)) (cadr PT))

L22 (list (+ kc (- 0 caot1 caot1) (car L11)) (cadr L11))

)

;;setq

)

;;if

(command "CECOLOR" 3 "line" p3 PT "" "line" p4 PTC "" "line" L1 L11 "" "line" L2 L22 "")

)

;;progn

)

;;if

(setvar "CECOLOR" lacol)

(setvar "osmode" om)

(prompt "\n\n")

(command "Undo" "End")

(setvar "cmdecho" 1)

(princ)

)

;;DONG toa do

em có lisp này của anh duy cung khá hay, mà lại thao tác it hơn, anh chỉnh lại dùm em vơi. cho y nằm dưới đường line và thêm cái vong tron cho em với, cái lisp anh cho phía sau không co số thập phân.

(Defun c:xtd ( )
(setq lc (strcase (getstring "\nBan co muon chon diem toa do gia dinh khong: Co/Khong: ")))

(if (= lc "C")
(progn
(setq a (getpoint "\nChon diem gia dinh: "))
(setq ax (dnint "\nToa do X gia dinh...

em có lisp này của anh duy cung khá hay, mà lại thao tác it hơn, anh chỉnh lại dùm em vơi. cho y nằm dưới đường line và thêm cái vong tron cho em với, cái lisp anh cho phía sau không co số thập phân.

(Defun c:xtd ( )
(setq lc (strcase (getstring "\nBan co muon chon diem toa do gia dinh khong: Co/Khong: ")))

(if (= lc "C")
(progn
(setq a (getpoint "\nChon diem gia dinh: "))
(setq ax (dnint "\nToa do X gia dinh "ax1))
(setq ax1 ax)
(setq ay (dnint "\nToa do Y gia dinh "ay1))
(setq ay1 ay)

(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(command "-style" "thep" "VNI-HELVE" "0" "1" "0" "n" "n")
(if (null met)(setq met 1))
(Setq temp T)
(While temp
(setq b (strcat "\nTi le /: "))
(Initget "t T")
(setq str (getpoint b))
(Cond
((= str "t") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
((= str "T") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
(Progn
(Setq b str)
(setq momet met)
(setq temp nil)
)
)
)
(setq c (getpoint b"\nChon diem viet ket qua: "))
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))

(setq xg (/ (car a) met))
(setq yg (/ (cadr a) met))
(setq kx (- x xg))
(setq ky (- y yg))
(setq xm (+ kx ax))
(setq ym (+ ky ay))

(setq toadox (rtos xm 2 3))
(setq toadoy (rtos ym 2 3))
(setq noidungviet (strcat toadox "\\P" toadoy))
(command ".LEADER" b c "" noidungviet "")


(setvar "osmode" luubatdiem) (setvar "clayer" luulop)
(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(while
(setq b (getpoint "\nChon diem muon xem toa do : "))

(setq c (getpoint b"\nChon diem viet ket qua: "))
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))
(setq xg (/ (car a) met))
(setq yg (/ (cadr a) met))
(setq kx (- x xg))
(setq ky (- y yg))
(setq xm (+ kx ax))
(setq ym (+ ky ay))

(setq toadox (rtos xm 2 3))
(setq toadoy (rtos ym 2 3))
(setq noidungviet (strcat toadox "\\P" toadoy))
(command ".LEADER" b c "" noidungviet "")


(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


)


)
)


(if (= lc "K")
(progn
(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(command "-style" "thep" "VNI-HELVE" "0" "1" "0" "n" "n")
(if (null met)(setq met 1))
(Setq temp T)
(While temp
(setq b (strcat "\nTi le /: "))
(Initget "t T")
(setq str (getpoint b))
(Cond
((= str "t") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
((= str "T") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
(Progn
(Setq b str)
(setq momet met)
(setq temp nil)
)
)
)
(setq c (getpoint b"\nChon diem viet ket qua: "))
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))

(setq toadox (rtos x 2 3))
(setq toadoy (rtos y 2 3))
(setq noidungviet (strcat toadox "\\P" toadoy))
(command ".LEADER" b c "" noidungviet "")

(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(while
(setq b (getpoint "\nChon diem muon xem toa do : "))
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))
(setq c (getpoint b"\nChon diem viet ket qua: "))
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq toadox (rtos x 2 3))
(setq toadoy (rtos y 2 3))
(setq noidungviet (strcat toadox "\\P" toadoy))
(command ".LEADER" b c "" noidungviet "")

(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


)


)
)





(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(Princ)
)


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

(Defun c:lkd ( )
(setq lc (strcase (getstring "\nBan co muon chon diem toa do gia dinh khong: Co/Khong: ")))

(if (= lc "C")
(progn
(setq a (getpoint "\nChon diem gia dinh: "))
(setq ax (dnint "\nToa do X gia dinh "ax1))
(setq ax1 ax)
(setq ay (dnint "\nToa do Y gia dinh "ay1))
(setq ay1 ay)

(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(command "-style" "thep" "VNI-HELVE" "0" "1" "0" "n" "n")
(if (null met)(setq met 1))
(Setq temp T)
(While temp
(setq b (strcat "\nTi le /: "))
(Initget "t T")
(setq str (getpoint b))
(Cond
((= str "t") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
((= str "T") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
(Progn
(Setq b str)
(setq momet met)
(setq temp nil)
)
)
)
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))

(setq xg (/ (car a) met))
(setq yg (/ (cadr a) met))
(setq kx (- x xg))
(setq ky (- y yg))
(setq xm (+ kx ax))
(setq ym (+ ky ay))


(command "INSERT" (strcat odiachay "\\tienich\\dwg\\nhap") (list (car b)(cadr b)) 1 1 0)
(setq xht (getreal "\nSo thu tu cua nut : "))
(setq xh (- xht 1))
(setq nx (* 8 xh))
(setq sb (/ xh 10))
(setq sbn (* 100 (fix sb)))
(setq snl (- xh (fix sb)))
(setq nl (- nx (* 80 (fix sb))))

(setq CHIAM (/ XHT 10))
(setq LAMCHAN (fix CHIAM))
(setq NHANM (* LAMCHAN 10))
(setq tenkc (- XHT NHANM))
(setq tenkcn (* TENKC 100))
(setq TENKCM (fix TENKCN))

(Cond
((= TENKCM 100) (command "INSERT" (strcat odiachay "\\tienich\\dwg\\tdbdiem") (list (- sbn 14) (- 6 nl)) 1 1 0)
)
((/= TENKCM 100)
)
)

(command "TEXT" (list (+ 0 sbn) (- 0 nl)) 4 0 (rtos xm 2 4))
(command "TEXT" (list (+ 42 sbn) (- 0 nl)) 4 0 (rtos ym 2 4))
(command "TEXT" (list (- sbn 10) (- 0 nl)) 4 0 (fix xht))
(command "LINE" (list (- sbn 14) (- (- 6 nl) 8))(list (+ sbn 80) (- (- 6 nl) 8)) "")
(command "LINE" (list (- sbn 14) (- 6 nl))(list (- sbn 14)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 12) (- 6 nl))(list (+ (- sbn 14) 12)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 53) (- 6 nl))(list (+ (- sbn 14) 53)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 94) (- 6 nl))(list (+ (- sbn 14) 94)(- (- 6 nl) 8)) "")
(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(while
(setq b (getpoint "\nChon diem muon xem toa do : "))

(setq x (/ (car b) met))
(setq y (/ (cadr b) met))
(setq xg (/ (car a) met))
(setq yg (/ (cadr a) met))
(setq kx (- x xg))
(setq ky (- y yg))
(setq xm (+ kx ax))
(setq ym (+ ky ay))

(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "MODEMACRO" "LIET KE TOA DO TAI DIEM 0-0")
(setvar "osmode" 0)
(command "INSERT" (strcat odiachay "\\tienich\\dwg\\nhap") (list (car b)(cadr b)) 1 1 0)
(setq xht (getreal "\nSo thu tu cua nut : "))
(setq xh (- xht 1))
(setq nx (* 8 xh))
(setq sb (/ xh 10))
(setq sbn (* 100 (fix sb)))
(setq snl (- xh (fix sb)))
(setq nl (- nx (* 80 (fix sb))))

(setq CHIAM (/ XHT 10))
(setq LAMCHAN (fix CHIAM))
(setq NHANM (* LAMCHAN 10))
(setq tenkc (- XHT NHANM))
(setq tenkcn (* TENKC 100))
(setq TENKCM (fix TENKCN))

(Cond
((= TENKCM 100) (command "INSERT" (strcat odiachay "\\tienich\\dwg\\tdbdiem") (list (- sbn 14) (- 6 nl)) 1 1 0)
)
((/= TENKCM 100)
)
)

(command "TEXT" (list (+ 0 sbn) (- 0 nl)) 4 0 (rtos xm 2 4))
(command "TEXT" (list (+ 42 sbn) (- 0 nl)) 4 0 (rtos ym 2 4))
(command "TEXT" (list (- sbn 10) (- 0 nl)) 4 0 (fix xht))
(command "LINE" (list (- sbn 14) (- (- 6 nl) 8))(list (+ sbn 80) (- (- 6 nl) 8)) "")
(command "LINE" (list (- sbn 14) (- 6 nl))(list (- sbn 14)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 12) (- 6 nl))(list (+ (- sbn 14) 12)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 53) (- 6 nl))(list (+ (- sbn 14) 53)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 94) (- 6 nl))(list (+ (- sbn 14) 94)(- (- 6 nl) 8)) "")
(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


)


)
)


(if (= lc "K")
(progn
(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(command "-style" "thep" "VNI-HELVE" "0" "1" "0" "n" "n")
(if (null met)(setq met 1))
(Setq temp T)
(While temp
(setq b (strcat "\nTi le /: "))
(Initget "t T")
(setq str (getpoint b))
(Cond
((= str "t") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
((= str "T") (setq met (dnint "\nMot met ban ve la bao nhieu "momet)))
(Progn
(Setq b str)
(setq momet met)
(setq temp nil)
)
)
)
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "osmode" 0)
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))
(command "INSERT" "C:\\tailieukythuat\\dwg\\nhap" (list (car b)(cadr b)) 1 1 0)
(setq xht (getreal "\nSo thu tu cua nut : "))
(setq xh (- xht 1))
(setq nx (* 8 xh))
(setq sb (/ xh 10))
(setq sbn (* 100 (fix sb)))
(setq snl (- xh (fix sb)))
(setq nl (- nx (* 80 (fix sb))))

(setq CHIAM (/ XHT 10))
(setq LAMCHAN (fix CHIAM))
(setq NHANM (* LAMCHAN 10))
(setq tenkc (- XHT NHANM))
(setq tenkcn (* TENKC 100))
(setq TENKCM (fix TENKCN))

(Cond
((= TENKCM 100) (command "INSERT" "C:\\tailieukythuat\\dwg\\tdbdiem" (list (- sbn 14) (- 6 nl)) 1 1 0)
)
((/= TENKCM 100)
)
)

(command "TEXT" (list (+ 0 sbn) (- 0 nl)) 4 0 (rtos x 2 4))
(command "TEXT" (list (+ 42 sbn) (- 0 nl)) 4 0 (rtos y 2 4))
(command "TEXT" (list (- sbn 10) (- 0 nl)) 4 0 (fix xht))
(command "LINE" (list (- sbn 14) (- (- 6 nl) 8))(list (+ sbn 80) (- (- 6 nl) 8)) "")
(command "LINE" (list (- sbn 14) (- 6 nl))(list (- sbn 14)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 12) (- 6 nl))(list (+ (- sbn 14) 12)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 53) (- 6 nl))(list (+ (- sbn 14) 53)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 94) (- 6 nl))(list (+ (- sbn 14) 94)(- (- 6 nl) 8)) "")
(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(while
(setq b (getpoint "\nChon diem muon xem toa do : "))
(setq x (/ (car b) met))
(setq y (/ (cadr b) met))
(setq luubatdiem (getvar "osmode")) (setq luulop (getvar "clayer"))
(setvar "MODEMACRO" "LIET KE TOA DO TAI DIEM 0-0")
(setvar "osmode" 0)
(command "INSERT" "C:\\tailieukythuat\\dwg\\nhap" (list (car b)(cadr b)) 1 1 0)
(setq xht (getreal "\nSo thu tu cua nut : "))
(setq xh (- xht 1))
(setq nx (* 8 xh))
(setq sb (/ xh 10))
(setq sbn (* 100 (fix sb)))
(setq snl (- xh (fix sb)))
(setq nl (- nx (* 80 (fix sb))))

(setq CHIAM (/ XHT 10))
(setq LAMCHAN (fix CHIAM))
(setq NHANM (* LAMCHAN 10))
(setq tenkc (- XHT NHANM))
(setq tenkcn (* TENKC 100))
(setq TENKCM (fix TENKCN))

(Cond
((= TENKCM 100) (command "INSERT" "C:\\tailieukythuat\\dwg\\tdbdiem" (list (- sbn 14) (- 6 nl)) 1 1 0)
)
((/= TENKCM 100)
)
)

(command "TEXT" (list (+ 0 sbn) (- 0 nl)) 4 0 (rtos x 2 4))
(command "TEXT" (list (+ 42 sbn) (- 0 nl)) 4 0 (rtos y 2 4))
(command "TEXT" (list (- sbn 10) (- 0 nl)) 4 0 (fix xht))
(command "LINE" (list (- sbn 14) (- (- 6 nl) 8))(list (+ sbn 80) (- (- 6 nl) 8)) "")
(command "LINE" (list (- sbn 14) (- 6 nl))(list (- sbn 14)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 12) (- 6 nl))(list (+ (- sbn 14) 12)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 53) (- 6 nl))(list (+ (- sbn 14) 53)(- (- 6 nl) 8)) "")
(command "LINE" (list (+ (- sbn 14) 94) (- 6 nl))(list (+ (- sbn 14) 94)(- (- 6 nl) 8)) "")
(setvar "osmode" luubatdiem) (setvar "clayer" luulop)


)


)
)





(setvar "MODEMACRO" "**TAILIEUKYTHUAT.COM**")
(Princ)
)

;---------------------------------------
(defun nstr (stri def)
(princ stri)
(princ "<")
(princ " ")
(princ def)
(princ ">")
(princ ":")
(princ " ")
);defun nstr
;--------------------
(defun nstr1 (stri)
(princ stri)
(princ "<")
(princ "Nhap vao")
(princ ">")
(princ ":")
(princ " ")
);defun nstr1
;---------------------
(defun nint (prompt def / temp)
(if def
(setq temp (getint (nstr prompt def)))
(setq def (getint (nstr1 prompt)))
);if def
(if temp
(setq def temp)
def
);if temp
);defun nint
;---------------------
(defun dnint (prompt def / temp)
(if def
(setq temp (getreal (nstr prompt def)))
(setq def (getreal (nstr1 prompt)))
);if def
(if temp
(setq def temp)
def
);if temp
);defun nint
;--------------------
(defun ndist (po prompt def / temp) ;nhan kh/cach va luu gia tri mac dinh
(if def
(setq temp (getdist po (nstr prompt def)))
(setq def (getdist po (nstr1 prompt)))
)if def
(if temp
(setq def temp)
def
);if temp
);defun ndist

Hic cái đó mình liên hệ rất lâu và nhiều lần rồi mà ko liên lạc được chứ ko phải ko xin ="=!

Đây bạn!

;Ve Dim kieu Pline/Spline.
; =============================================================================
; Filename    :   DimPoly.lsp
; Datum       :   08.03.06
; Author      :  ...
>>

Hic cái đó mình liên hệ rất lâu và nhiều lần rồi mà ko liên lạc được chứ ko phải ko xin ="=!

Đây bạn!

;Ve Dim kieu Pline/Spline.
; =============================================================================
; Filename    :   DimPoly.lsp
; Datum       :   08.03.06
; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH, Switzerland
; Revision  1 :   10.03.06 jme - DIMBLK1/2, DIMSE1/2 and DIMDLE support added
;                              - Bug Text rotation fixed
;                              - Code refined
; Revision  2 :   13.03.06 jme - Bug attribute insertion point fixed
;                              - Flag 70 excluded in Spline flag check
; Revision  3 :   __.__.__ ___ -
; -----------------------------------------------------------------------------
; Description:
; Creates a Polyline/Spline dimension.
; -----------------------------------------------------------------------------
; Global variables:
; Me:AcD
; -----------------------------------------------------------------------------
; Internal LISP-functions:
; MeAddArrowObjects  MeCalcArrow  MeGetAssoc  MeGetCurSpace  MeGetEndPoints
; MeGetObjLength  MeGetObjMidPoint  MeGetTangentAtPoint  MeTranslateDimBklName
; MeSelPline  MeShorten  MeTan
; -----------------------------------------------------------------------------
; External LISP-functions:
; None
; -----------------------------------------------------------------------------
; Version notes:
; AutoCAD: Version: Language: AddIns:
; 15 up 1.02 English ...
; -----------------------------------------------------------------------------
;
; == Message on loading =======================================================
;
(princ "\nDimPoly v1.02")
;
; == Main =====================================================================
;
(defun C:DimPoly ( / BlkLst CurEnt CurObj CurSpc DimAsz DimBl1 DimBl2 DimDle
                     DimEnt DimExe DimExo DimGap DimObj DimScl DimTxt DimVal
                     FstAng FstBpt FstDpt FstPnt NxtAng NxtBpt NxtDpt NxtPnt
                     ObjNme OldCmd OldOsm PntLst TmpBlk TmpObj TxtAng TxtIpt
                     *Error*)
 ; - Check for AutoCAD version 15.0+
 (if (< (atof (getvar "ACADVER")) 15.0)
  (alert " DimPoly requires AutoCAD 2000 or higher. ")
  (progn
   ; - Initialize ActiveX
   (vl-load-com)
   ; - Get AutoCAD's current document
   (or Me:AcD (setq Me:AcD (vla-get-ActiveDocument (vlax-get-acad-object))))
   ; - Save system variables
   (setq OldCmd (getvar "CMDECHO")
         OldOsm (getvar "OSMODE")
   )
   ; - Establish error handler
   (defun *error* (Msg)
    (setvar "CMDECHO" OldCmd)
    (setvar "OSMODE" OldOsm)
    (vla-EndUndoMark Me:AcD)
    (if Msg (princ Msg))
    (princ)
   )
   ; - Begin program
   (vla-StartUndoMark Me:AcD)
   (if (setq CurEnt (MeSelPline "\nSelect Polyline or Spline: " nil nil))
    (progn
     (setq FstPnt (cadr CurEnt)
           CurEnt (car CurEnt)
           CurObj (vlax-ename->vla-object CurEnt)
           NxtPnt (getpoint FstPnt "\nDimension line position: ")
     )
     (setvar "CMDECHO" 0)
     (setvar "OSMODE" 0)
     (cond
      ((not NxtPnt))
      ((not (vl-cmdf "_.OFFSET" (distance FstPnt NxtPnt) CurEnt NxtPnt ""))
       (princ "can't offset this object. ")
      )
      (T
       (setq DimEnt (entlast)
             DimObj (vlax-ename->vla-object DimEnt)
       )
       (if (not (eq (vla-get-ObjectName DimObj) "AcDbSpline"))
        (vla-put-ConstantWidth DimObj 0.0)
       )
       (vla-put-Color DimObj (getvar "DIMCLRD"))
       (vla-put-LineWeight DimObj (getvar "DIMLWD"))
       (setq CurSpc (MeGetCurSpace)
             PntLst (MeGetEndPoints CurObj)
             FstBpt (car PntLst)
             NxtBpt (cadr PntLst)
             PntLst (MeGetEndPoints DimObj)
             FstDpt (car PntLst)
             NxtDpt (cadr PntLst)
             DimVal (MeGetObjLength CurObj)
             TxtIpt (MeGetObjMidPoint DimObj)
             DimScl (getvar "DIMSCALE")
             DimBl1 (MeTranslateDimBklName (getvar "DIMBLK1"))
             DimBl2 (MeTranslateDimBklName (getvar "DIMBLK2"))
             BlkLst '("_DOTSMALL" "_SMALL" "_NONE"
                      "_OBLIQUE" "_INTEGRAL" "_ARCHTICK"
                     )
             DimExe (* DimScl (getvar "DIMEXE"))
             DimExo (* DimScl (getvar "DIMEXO"))
             DimDle (* DimScl (getvar "DIMDLE"))
             DimTxt (* DimScl (getvar "DIMTXT"))
             DimAsz (* DimScl (getvar "DIMASZ"))
             DimGap (+ (* DimScl (getvar "DIMGAP")) (/ DimTxt 2.0))
             TxtAng (MeGetTangentAtPoint DimObj TxtIpt)
             TxtAng (if (and (> TxtAng (* pi 0.5)) (<= TxtAng (* pi 1.5)))
                     (- TxtAng pi)
                     TxtAng
                    )
             TxtIpt (polar TxtIpt (+ TxtAng (* pi 0.5)) DimGap)
             FstAng (MeGetTangentAtPoint DimObj FstDpt)
             NxtAng (MeGetTangentAtPoint DimObj NxtDpt)
             TmpBlk (vlax-invoke (vla-get-Blocks Me:AcD) 'Add
                    '(0.0 0.0 0.0) "*U"
                    )
             TmpObj (vlax-invoke TmpBlk 'AddAttribute
                     DimTxt acAttributeModePreset "" TxtIpt "DIMTXT"
                     (rtos DimVal (getvar "DIMLUNIT") (getvar "DIMDEC"))
                    )
       )
       (vla-put-Rotation TmpObj TxtAng)
       (vla-put-StyleName TmpObj (getvar "DIMTXSTY"))
       (vla-put-Alignment TmpObj acAlignmentMiddle)
       (vlax-put TmpObj 'TextAlignmentPoint TxtIpt)
       (vla-put-Color TmpObj (getvar "DIMCLRT"))
       (if (= (getvar "DIMSE1") 0)
        (progn
         (setq TmpObj (vlax-invoke TmpBlk 'AddLine
                       (polar FstBpt (angle FstBpt FstDpt) DimExo)
                       (polar FstDpt (angle FstBpt FstDpt) DimExe)
                      )
         )
         (vla-put-Color TmpObj (getvar "DIMCLRE"))
         (vla-put-LineWeight TmpObj (getvar "DIMLWE"))
        )
       )
       (if (= (getvar "DIMSE2") 0)
        (progn
         (setq TmpObj (vlax-invoke TmpBlk 'AddLine
                       (polar NxtBpt (angle NxtBpt NxtDpt) DimExo)
                       (polar NxtDpt (angle NxtBpt NxtDpt) DimExe)
                      )
         )
         (vla-put-Color TmpObj (getvar "DIMCLRE"))
         (vla-put-LineWeight TmpObj (getvar "DIMLWE"))
        )
       )
       (if (and (> DimDle 0.0) (vl-position DimBl1 BlkLst))
        (progn
         (setq TmpObj (vlax-invoke TmpBlk 'AddLine
                       FstDpt (polar FstDpt (+ FstAng pi) DimDle)
                      )
         )
         (vla-put-Color TmpObj (getvar "DIMCLRD"))
         (vla-put-LineWeight TmpObj (getvar "DIMLWD"))
        )
       )
       (if (and (> DimDle 0.0) (vl-position DimBl2 BlkLst))
        (progn
         (setq TmpObj (vlax-invoke TmpBlk 'AddLine
                       NxtDpt (polar NxtDpt NxtAng DimDle)
                      )
         )
         (vla-put-Color TmpObj (getvar "DIMCLRD"))
         (vla-put-LineWeight TmpObj (getvar "DIMLWD"))
        )
       )
       (if (vl-position DimBl1 BlkLst)
        (MeAddArrowObjects FstDpt FstAng DimAsz DimBl1 TmpBlk)
        (progn
         (MeShorten DimEnt DimAsz (car PntLst))
         (setq PntLst (MeGetEndPoints DimObj)
               FstAng (angle (car PntLst) FstDpt)
         )
         (MeAddArrowObjects FstDpt FstAng DimAsz DimBl1 TmpBlk)
        )
       )
       (if (vl-position DimBl2 BlkLst)
        (MeAddArrowObjects NxtDpt (+ NxtAng pi) DimAsz DimBl2 TmpBlk)
        (progn
         (MeShorten DimEnt DimAsz (cadr PntLst))
         (setq PntLst (MeGetEndPoints DimObj)
               NxtAng (angle (cadr PntLst) NxtDpt)
         )
         (MeAddArrowObjects NxtDpt NxtAng DimAsz DimBl2 TmpBlk)
        )
       )
       (vlax-invoke Me:AcD 'CopyObjects (list DimObj) TmpBlk)
       (vla-Delete DimObj)
       (vlax-invoke CurSpc 'InsertBlock
       '(0.0 0.0 0.0) (vla-get-Name TmpBlk) 1.0 1.0 1.0 0.0
       )
      )
     )
    )
   )
   (*Error* nil)
  )
 )
 (princ)
)
;
; == Subs =====================================================================
;
; == Function MeAddArrowObjects
; Adds the requestet arrow objects to a block object.
; Argumens :
;   Pnt = Start point 
;   Ang = Rotation angle 
;   Siz = Arrow size 
;   Nme = Dimension block name 
;   Obj = Add to block 
; Return :
;   > Null
; Notes:
;   - Requires the global variable Me:AcD
;
(defun MeAddArrowObjects (Pnt Ang Siz Nme Obj / ArwObj BlkNme CurSpc ObjLst
                                                PntLst TmpObj)
 (cond
  ((eq Nme "_NONE"))
  ((eq Nme "")
   (setq PntLst (MeCalcArrow Pnt Siz)
         ArwObj (vlax-invoke Obj 'AddSolid
                 (car PntLst) (cadr PntLst)
                 (caddr PntLst) (car PntLst)
                )
   )
   (vlax-invoke ArwObj 'Rotate Pnt (+ Ang pi))
   (vla-put-Color ArwObj (getvar "DIMCLRD"))
   (vla-put-LineWeight ArwObj (getvar "DIMLWD"))
  )
  (T
   (setq CurSpc (MeGetCurSpace)
         TmpObj (vlax-invoke CurSpc 'InsertBlock Pnt Nme Siz Siz Siz Ang)
         ObjLst (vlax-invoke TmpObj 'Explode)
   )
   (vla-Delete TmpObj)
   (mapcar '(lambda (l) (vla-put-Color l (getvar "DIMCLRD"))) ObjLst)
   (mapcar '(lambda (l) (vla-put-LineWeight l (getvar "DIMLWD"))) ObjLst)
   (vlax-invoke Me:AcD 'CopyObjects ObjLst Obj)
   (mapcar 'vla-Delete ObjLst)
  )
 )
 (princ)
)
;
; == Function MeCalcArrow
; Returns the points of an arrow, calculated by size.
; Argumens :
;   Pnt = Start point 
;   Siz = Arrow size 
; Return :
;   > Point list (Pt1 Pt1 Pt3) 
; Notes:
;   - None
;
(defun MeCalcArrow (Pnt Siz / Angl_A Side_A)
 (setq Side_A (/ Siz 6.0)
       Angl_A (MeTan (/ Side_A Siz))
 )
 (list
  (polar Pnt Angl_A (/ Side_A (sin Angl_A)))
  (polar Pnt (- Angl_A) (/ Side_A (sin Angl_A)))
  Pnt
 )
)
;
; == Function MeGetAssoc
; Get associative value from a list.
; Arguments :
;   Key = Key to search 
;   Lst = Dotted pair list 
; Return :
;   > Value 
; Notes:
;   - None
;
(defun MeGetAssoc (Key Lst)
 (cdr (assoc Key Lst))
)
;
; == Function MeGetCurSpace
; Returns the current space object.
; Arguments :
;   --- = 
; Return :
;   > Mspace or Pspace object 
; Notes:
;   - Requires the global variable Me:AcD
;
(defun MeGetCurSpace ()
 (if (or (= (getvar "TILEMODE") 1) (> (getvar "CVPORT") 1))
  (vla-get-ModelSpace Me:AcD)
  (vla-get-PaperSpace Me:AcD)
 )
)
;
; == Function MeGetEndPoints
; Returns the endpoints of an object.
; Arguments :
;   Obj = Object 
; Return :
;   > Endpoints '((x y z) (x y z)) 
;   > Nil if invalid object
; Notes:
;   - Proceeds *Polylines, Splines, Lines, Arcs, Circles and Ellipses
; 
(defun MeGetEndPoints (Obj)
 (list
  (vlax-curve-getStartPoint Obj)
  (vlax-curve-getEndPoint Obj)
 )
)
;
; == Function MeGetObjLength
; Returns the length of an object.
; Arguments :
;   Obj = Object 
; Return :
;   > Length of the object 
; Notes:
;   - Proceeds *Polylines, Splines, Lines, Arcs, Circles and Ellipses
; 
(defun MeGetObjLength (Obj)
 (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj))
)
;
; == Function MeGetObjMidPoint
; Returns the middle point of an object.
; Arguments :
;   Obj = Object 
; Return :
;   > Length of the object 
; Notes:
;   - Proceeds *Polylines, Splines, Lines, Arcs, Circles and Ellipses
; 
(defun MeGetObjMidPoint (Obj / CurDst)
 (setq CurDst (vlax-curve-getDistAtParam Obj
               (vlax-curve-getEndParam Obj)
              )
 )
 (vlax-curve-getPointAtDist Obj (/ CurDst 2.0))
) 
;
; == Function MeGetTangentAtPoint
; Returns the tangent at the specified point.
; Arguments :
;   Obj = Object 
;   Pnt = Point on object 
; Return :
;   > Tangent angle at point 
;   > False if point is not on object.
; Notes:
;   - None
;
(defun MeGetTangentAtPoint (Obj Pnt / CurPar PntLst TmpPnt)
 (setq PntLst (MeGetEndPoints Obj)
       CurPar (cond
               ((equal Pnt (car PntLst) 1E-6)
                (vlax-curve-getStartParam Obj)
               )
               ((equal Pnt (cadr PntLst) 1E-6)
                (vlax-curve-getEndParam Obj)
               )
               ((setq TmpPnt (vlax-curve-getClosestPointTo Obj Pnt))
                (if (<= (distance TmpPnt Pnt) 1E-6)
                 (vlax-curve-getParamAtPoint Obj TmpPnt)
                )
               )
               (T nil)
              )
 )
 (if CurPar
  (angle
  '(0.0 0.0 0.0)
   (vlax-curve-getFirstDeriv Obj CurPar)
  )
 )
)
;
; == Function MeSelPline
; Extended Polyline selection function.
; Arguments :
;   Pmt = User prompt 
;   3Dp = 3Dpolyline flag (3Dpolyline allowed) 
;   Cls = Close flag (pline must be closed) 
; Return :
;   > List with entity name and pickpoint '((Ename (x y z)) 
; Notes:
;   - Credits to James Allen
;   - Returns nil when user press 'Return' or 'Space'
;
(defun MeSelPline (Pmt 3Dp Cls / CurEnt EntFlg EntLst EntNme ExLoop)
 (while (not ExLoop)
  (initget " ")
  (setq CurEnt (entsel Pmt))
  (cond
   ((= CurEnt "") (setq ExLoop T CurEnt nil))
   (CurEnt
    (setq EntLst (entget (car CurEnt))
          EntNme (MeGetAssoc 0 EntLst)
          EntFlg (MeGetAssoc 70 EntLst)
          CurEnt (list
                  (car CurEnt)
                  (trans
                   (if (eq EntNme "POLYLINE")
                    (vlax-curve-getClosestPointToProjection
                     (car CurEnt)
                     (trans (cadr CurEnt) 1 0)
                     (trans (getvar "VIEWDIR") 1 0 1)
                    )
                    (cond ((osnap (cadr CurEnt) "_nea")) ((cadr CurEnt)))
                   )
                   0 1
                  )
                 )
    )
    (cond
     ((or
       (not (member EntNme '("LWPOLYLINE" "POLYLINE" "SPLINE")))
       (and (not 3Dp) (not (eq EntNme "SPLINE")) (= (logand EntFlg  8) 8))
       (and (not (eq EntNme "SPLINE")) (= (logand EntFlg 16) 16))
       (and (not (eq EntNme "SPLINE")) (= (logand EntFlg 64) 64))
      )
      (princ "selected entity is not a Polyline or Spline. ")
     )
     ((and Cls (/= (logand EntFlg 1) 1))
      (princ "selected Polyline or Spline is not closed. ")
     )
     ((setq ExLoop T))
    )
   )
   ((princ "1 selected, 0 found. "))
  )
 )
 CurEnt
)
;
; == Function MeShorten
; Shortens an object at end point by distance.
; Arguments :
;   Ent = Entity 
;   Dst = Shorten distance 
;   Pnt = Point on end 
; Return :
;   > Null
; Notes:
;   - None
;
(defun MeShorten (Ent Dst Pnt / ObjLen TmpPnt)
 (setq ObjLen (MeGetObjLength Ent))
 (if (and (> Dst 0.0) (< Dst ObjLen))
  (vl-cmdf "_.LENGTHEN"  "_TOT" (- ObjLen Dst) (list Ent Pnt) "")
 )
 (princ)
)
;
; == Function MeTan
; Returns tangens of an angle.
; Argumens :
;   Ang = Angle (radians) 
; Return :
;   > Tangens 
; Notes:
;   - None
;
(defun MeTan (Ang) (/ (sin Ang) (cos Ang)))
;
; == Function MeTranslateDimBklName
; Returns the arrow block name by language of the current AutoCAD version.
; Arguments :
;   Nme = Arrow name 
; Return :
;   > Arrow block name 
; Notes:
;   - Autodesk has no f*@#%*g concept for DIMBLK(1/2)!!!
;     That's the reason why we need this translation table.
;   - In case you wanna add a new language support, you've to check each
;     value by setting DIMBLK first by English key (eg. _DOT). Then call
;     DIMBLK again and add the default value as the first atom in the
;     list (upper case).
;
(defun MeTranslateDimBklName (Nme / AcdLng RegPth TrlLst)
 (setq RegPth (strcat "HKEY_LOCAL_MACHINE\\" (vlax-product-key))
       AcdLng (vl-registry-read RegPth "Language")
       TrlLst (cond
               ((eq AcdLng "Deutsch")
               '(("" . "")
                 ("PUNKT" . "_DOT")
                 ("PUNKTKLEIN" . "_DOTSMALL")
                 ("PUNKTLEER" . "_DOTBLANK")
                 ("URSPRUNG" . "_ORIGIN")
                 ("URSPRUNG2" . "_ORIGIN2")
                 ("GEÖFFNET" . "_OPEN")
                 ("GEÖFFNET90" . "_OPEN90")
                 ("GEÖFFNET30" . "_OPEN30")
                 ("GESCHLOSSEN" . "_CLOSED")
                 ("KLEIN" . "_SMALL")
                 ("KEIN" . "_NONE")
                 ("SCHRÄG" . "_OBLIQUE")
                 ("QUADRATGEFÜLLT" . "_BOXFILLED")
                 ("QUADRATLEER" . "_BOXBLANK")
                 ("GESCHLOSSENLEER" . "_CLOSEDBLANK")
                 ("UMGEKDREIECKGEFÜLLT" . "_DATUMFILLED")
                 ("UMGEKDREIECKLEER" . "_DATUMBLANK")
                 ("INTEGRAL" . "_INTEGRAL")
                 ("ARCHITEKTONISCH" . "_ARCHTICK")
                )
               )
               ((eq AcdLng "Français")
               '(("" . "")
                 ("POINT" . "_DOT")
                 ("PETITPOINT" . "_DOTSMALL")
                 ("POINTVIDE" . "_DOTBLANK")
                 ("ORIGINE" . "_ORIGIN")
                 ("ORIGINE2" . "_ORIGIN2")
                 ("OUVERTE" . "_OPEN")
                 ("ANGLEDROIT" . "_OPEN90")
                 ("ANGLE30" . "_OPEN30")
                 ("FERMÉ" . "_CLOSED")
                 ("PETIT" . "_SMALL")
                 ("AUCUNE" . "_NONE")
                 ("OBLIQUE" . "_OBLIQUE")
                 ("CARREPLEIN" . "_BOXFILLED")
                 ("CARREVIDE" . "_BOXBLANK")
                 ("FERMÉEVIDE" . "_CLOSEDBLANK")
                 ("TRIANGLEPLEININVERSE" . "_DATUMFILLED")
                 ("TRIANGLEVIDEINVERSE" . "_DATUMBLANK")
                 ("INTEGRALE" . "_INTEGRAL")
                 ("MARQUEARCH" . "_ARCHTICK")
                )
               )
               ((eq AcdLng "English")
               '(("" . "")
                 ("DOT" . "_DOT")
                 ("DOTSMALL" . "_DOTSMALL")
                 ("DOTBLANK" . "_DOTBLANK")
                 ("ORIGIN" . "_ORIGIN")
                 ("ORIGIN2" . "_ORIGIN2")
                 ("OPEN" . "_OPEN")
                 ("OPEN90" . "_OPEN90")
                 ("OPEN30" . "_OPEN30")
                 ("CLOSED" . "_CLOSED")
                 ("SMALL" . "_SMALL")
                 ("NONE" . "_NONE")
                 ("OBLIQUE" . "_OBLIQUE")
                 ("BOXFILLED" . "_BOXFILLED")
                 ("BOXBLANK" . "_BOXBLANK")
                 ("CLOSEDBLANK" . "_CLOSEDBLANK")
                 ("DATUMFILLED" . "_DATUMFILLED")
                 ("DATUMBLANK" . "_DATUMBLANK")
                 ("INTEGRAL" . "_INTEGRAL")
                 ("ARCHTICK" . "_ARCHTICK")
                )
               )
               (T
                (alert
                 (strcat
                  "Your AutoCad language is not supported."
                  "\nAdd the desired translation table in function: "
                  "\nMeTranslateDimBklName"
                 )
                )
                (exit)
               )
              )
 )
 (cond ((MeGetAssoc (strcase Nme) TrlLst)) (Nme))
)
;
; == Copyright - Note (May be never deleted) ==================================
;
(princ "\n-------------------------------------------")
(princ "\n ©2006 MENZI ENGINEERING GmbH, Switzerland ")
(princ "\n-------------------------------------------")
(princ "\nType DimPoly in the command line to start the programm...")
(princ)
;
; == End DimPoly ==============================================================
 

code nhanh cho Bạn. Lệnh là GNL, chọn và update lien tục các tên của linetype vào block, khi muốn kết thúc thì enter

(defun c:GNL (/ e b lay nam);get name linetype
  
  (while (and
	   (princ "\nChon Line, PLINE")
	   (setq e (ssget '((0 . "*LINE"))))
	   (princ "\nChon block")
	   (setq b (ssget '((0 . "insert") (66 . 1))))
	 )

    (setq lay (cdr (assoc 8 (setq e (entget (ssname e 0))))))
    (if	(not (setq nam (cdr (assoc 6 e))))
     ...
>>

code nhanh cho Bạn. Lệnh là GNL, chọn và update lien tục các tên của linetype vào block, khi muốn kết thúc thì enter

(defun c:GNL (/ e b lay nam);get name linetype
  
  (while (and
	   (princ "\nChon Line, PLINE")
	   (setq e (ssget '((0 . "*LINE"))))
	   (princ "\nChon block")
	   (setq b (ssget '((0 . "insert") (66 . 1))))
	 )

    (setq lay (cdr (assoc 8 (setq e (entget (ssname e 0))))))
    (if	(not (setq nam (cdr (assoc 6 e))))
      (setq nam (cdr (assoc 6 (tblsearch "LAYER" lay))))
    )
    (mapcar
      '(lambda (x)
	 (mapcar
	   '(lambda (Att)
	      (if
		(= (strcase (vla-get-TagString att)) "2T2K")
		 (vla-put-textstring att nam)
	      )
	    )
	   (vlax-invoke (vlax-ename->vla-object x) 'GetAttributes)

	 )
       )
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex b)))
    )

  )
  (princ)
  )

dạ em gữi kèm file cad mong được các anh giúp.

Mấy anh đặt tùy chỉnh luôn cho em cái này:(hình tròn và cỡ chữ có thể thay đổi được do người dùng chọn)

>>

dạ em gữi kèm file cad mong được các anh giúp.

Mấy anh đặt tùy chỉnh luôn cho em cái này:(hình tròn và cỡ chữ có thể thay đổi được do người dùng chọn)

http://www.cadviet.com/upfiles/5/133575_nho_viet_lisp.dwg

 

Đã code lại cho bạn rồi đây ^^

Bạn dùng thử xem sao nhé ^^

Tên lệnh: GTD

;;-----------------------=={ Xuat toa do diem }==-----------------------;;
;; ;;
;; Command : MBN ;;
;; Date : 26-Nov-2015 ;;
;;----------------------------------------------------------------------;;
;; Author : @ Tran Cong Son - Detail SS ;;
;;----------------------------------------------------------------------;;
(defun C:GTD (/ CAOTXT D1 DI DI1 DI2 DT DT1 DT2 DT3 I LST_VAR OLD_VAR STT TB1 TB2 TX TY)
(setvar "MODEMACRO" "@ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN")
;;-----------------=={ Make Text }==------------------;;
(defun TS:MakeText (point string justify / Lst)
(setq Lst
(list '(0 . "TEXT")
(cons 8 "gt-duong")
(cons 10 point)
(cons 40 caotxt)
(cons 1 string)
(cons 50 0.0)
(cons 7 "VNI-CON")
)
justify (strcase justify)
)
(cond
((= justify "R")
(setq Lst (append Lst (list (cons 72 2) (cons 11 point))))
)
((= justify "TL")
(setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3))))
)
((= justify "TR")
(setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3))))
)
)
(entmakex Lst)
)
;;-----------------=={ Make Pline }==------------------;;
(defun TS:MakePline (listpoint / Lst)
(setq Lst (list '(0
.
"LWPOLYLINE"
)
'(100 . "AcDbEntity")
(cons 8 "gt-duong")
(cons 6 "Continuous")
'(100 . "AcDbPolyline")
(cons 90 (length listpoint))
(cons 70 0)
)
)
(foreach PP listpoint
(setq Lst (append Lst (list (cons 10 PP))))
)
(entmakex Lst)
)
;;-----------------=={ Main Function }==------------------;;
(setvar "cmdecho" 0)
(command "Undo" "Begin")
(setq lst_var '("osmode" "dimzin")
old_var (mapcar 'getvar lst_var)
)
(mapcar 'setvar lst_var '(32 0))
(or *h*
(setq *h* 1)
)
(setq caotxt (getreal (strcat "\nCao text < " (rtos *h* 2 0) " >:")))
(if caotxt
(setq *h* caotxt)
(setq caotxt *h*)
)
(if (not (tblsearch "layer" "gt-duong"))
(vl-cmdf ".layer" "n" "gt-duong" "l" "Continuous" "gt-duong" "")
)
(if (not (tblsearch "Style" "VNI-CON"))
(vl-cmdf "_.Style" "VNI-CON" "VNI-HELVE-CONDENSE" 0 1 "" "" "")
)
(setq i 1
stt '()
)
(While
(setq D1 (getpoint (strcat "\nPick \U+0111i\U+1EC3m th\U+1EE9 " (rtos i 2 0) " :")))
(Progn
(entmake
(list (cons 0 "CIRCLE")
(cons 8 "gt-duong")
(cons 10 D1)
(cons 40 (* 0.15 caotxt))
)
)
(setq DT
(getpoint
D1
(strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t Text c\U+1EE7a n\U+00FAt th\U+1EE9 "
(rtos i 2 0)
" :"
)
)
)
(setq TX (strcat "X=" (rtos (car D1) 2 3))
TY (strcat "Y=" (rtos (cadr D1) 2 3))
stt (append stt (list i))
)
(if (>= (car DT) (car D1))
(progn
(setq DT1 (list (+ (car DT) (* 0.5 caotxt)) (+ (cadr DT) (* 0.25 caotxt)) 0.0)
DT2 (list (+ (car DT) (* 0.5 caotxt)) (- (cadr DT) (* 0.25 caotxt)) 0.0)
)
(TS:MakeText DT1 TX "L")
(setq TB1 (textbox (entget (entlast)))
di1 (distance (car TB1) (cadr TB1))
)
(TS:MakeText DT2 TY "TL")
(setq TB2 (textbox (entget (entlast)))
di2 (distance (car TB2) (cadr TB2))
)
(setq di (max di1 di2)
DT3 (polar DT 0 (+ di (* 0.5 caotxt)))
)
(TS:MakePline (list D1 DT DT3))
)
(progn
(setq DT1 (list (- (car DT) (* 0.5 caotxt)) (+ (cadr DT) (* 0.25 caotxt)) 0.0)
DT2 (list (- (car DT) (* 0.5 caotxt)) (- (cadr DT) (* 0.25 caotxt)) 0.0)
)
(TS:MakeText DT1 TX "R")
(setq TB1 (textbox (entget (entlast)))
di1 (distance (car TB1) (cadr TB1))
)
(TS:MakeText DT2 TY "TR")
(setq TB2 (textbox (entget (entlast)))
di2 (distance (car TB2) (cadr TB2))
)
(setq di (max di1 di2)
DT3 (polar DT pi (+ di (* 0.5 caotxt)))
)
(TS:MakePline (list D1 DT DT3))
)
)
)
(setq i (+ i 1))
)
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
)

 

Chúc mọi người làm việc zui zẻ !

<<

Rảnh >>> lại dâng sớ đây :D :D :D

Với BD bạn gửi lên:

- Chuyển Elevation của MEPTLP về 0

- Match tất cả line text tên cọc về layer "Texttencoc"

- EX để kéo dài: tim, MEPTLP, MEPTLT vượt qua  ENTCOC đầu và cuối

- Copy/ Paste block cocmoc (define block)

>>> Ap lisp >>> DONG5    :D

(defun c:DONG5 ( /...
>>

Rảnh >>> lại dâng sớ đây :D :D :D

Với BD bạn gửi lên:

- Chuyển Elevation của MEPTLP về 0

- Match tất cả line text tên cọc về layer "Texttencoc"

- EX để kéo dài: tim, MEPTLP, MEPTLT vượt qua  ENTCOC đầu và cuối

- Copy/ Paste block cocmoc (define block)

>>> Ap lisp >>> DONG5    :D

(defun c:DONG5 ( / lst_va old ss_coc ss lst_name tim tlt tlp lst_ten_coc lst_coc mid_pnt ten find ob trai phai mid_pt fn pw)
;
(vl-load-com)
;
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nQuet chon BD de lay ten coc !")
(setq ss_coc (ssget '((0 . "LINE") (8 . "Texttencoc"))))
(if ss_coc 
	(progn
		(princ "\n Chon MEPTLT, MEPTLP, tim tuyen !")
		(setq ss (ssget '((8 . "MEPTLT,MEPTLP,TUYEN"))))
		(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(setq tim (car (vl-remove-if-not '(lambda(x) (= "TUYEN" (cdr (assoc 8 (entget x))))) lst_name))
			tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
			tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
		(command ".zoom" "o" ss_coc "")
		(setq	lst_ten_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_coc)))
				lst_ten_coc (mapcar '(lambda (x) (list x (get_text_coc x 4.5 13))) lst_ten_coc))
		(setq lst_coc (ssget "_F" (lst_point_fence tim) '((0 . "LINE") (8 . "ENTCOC"))))
		(setq lst_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex lst_coc))))
		(setq lst_coc 
			(mapcar 
				'(lambda (x) 
					(setq	mid_pnt (mid (vlax-curve-getStartpoint x) (vlax-curve-getEndpoint x))
							i 0)
					(while (< i (length lst_ten_coc))
						(if (setq find (find_piles (car (setq ten (nth i lst_ten_coc))) mid_pnt 50)) (setq i (length lst_ten_coc)) (setq i (1+ i)))
					)	   ;while
					(if find (list x mid_pnt (last ten)) (list x mid_pnt "No name"))
				)
				lst_coc)
		)
		(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
		(setq pw (open fn "w"))
		(write-line "STT,Ten coc,Trai,,,Phai" pw)
		(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
		(foreach c lst_coc
			(setq 	mid_pt (cadr c)
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(command "_.insert" "cocmoc" trai 1 "" "")
			(command "_.insert" "cocmoc" phai 1 "" "")
			(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
			(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
			(write-line (strcat "," (last c) "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
		)
		(close pw)
	)
	(princ "\nKhong chon duoc line ten coc !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;==============================================================
(defun mid (p1 p2) (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
;;;;==============================================================
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)
;;;;===================================================================
(defun lst_point_fence (pl / info lst_bug lst_point i arc_len fence)
(setq	info (entget pl '("*"))
		lst_bug (vl-remove-if-not '(lambda(x) (= 42 (car x))) info)
		lst_point (vl-remove-if-not '(lambda(x) (= 10 (car x))) info)
		i 0)
(while (< i (length lst_bug))
	(cond 
		((/= 0 (cdr (nth i lst_bug)))
			(setq	fence (cons (cdr (nth i lst_point)) fence)
					arc_len (abs (- (setq start (vlax-curve-getDistAtPoint pl (cdr(nth i lst_point)))) (vlax-curve-getDistAtPoint pl (cdr (nth (setq i (1+ i)) lst_point)))))
					
			)
			(repeat 3 
				(setq 	fence (cons (vlax-curve-getPointAtDist pl (setq start (+ start (/ arc_len 4)))) fence))
			)
		)
		(t (setq 
				fence (cons (cdr (nth i lst_point)) fence)
				i (1+ i))
		)
	)
)
(reverse fence)
)
;;;===============================================================
(defun get_text_coc (ent h w / info dau_line cuoi_line pt1 pt2 pt3 pt4 ss)
;ham lay text ten coc thuoc layer "Texttencoc" khi co line vach chi gan text
;h, w: chieu cao, rong cuar window vung chon
(setq	dau_line (cdr (assoc 10 (setq info (entget ent))))
		cuoi_line (cdr (assoc 11 info))
		pt1 (polar cuoi_line (+ (setq ang_line (angle dau_line cuoi_line)) (* 0.5 pi)) (* 0.5 w))
		pt2 (polar pt1 ang_line h)
		pt3 (polar pt2 (- ang_line (* 0.5 pi)) w)
		pt4 (polar cuoi_line (- ang_line (* 0.5 pi)) (* 0.5 w))
)
(setq ss (ssget "_WP" (list pt1 pt2 pt3 pt4) '((0 . "TEXT") (8 . "Texttencoc"))))
(if ss (cdr (assoc 1 (entget (ssname ss 0)))) "No_name")
)
;;;===================================================================
(defun find_piles (line_piles_name pnt_piles lim / st end)
;Tu line ten coc, tim thay point tim coc trong gioi han khoang cach (dien ten coc)
(setq	st (vlax-curve-getStartpoint line_piles_name)
		end (vlax-curve-getEndpoint line_piles_name))
(if (and (<= (distance end pnt_piles) lim) (equal (angle end st) (angle end pnt_piles) 1e-3)) T)
)

p/s:

Vì mình trình còn non, code theo kiểu luyện bài cũ >>> Lisp này chủ yếu để chạy trên bản vẽ này, trên bản khác thì có thể phát sinh lỗi ngay nếu không hiệu chỉnh một vài thứ :D

Lỗi xảy ra vẫn vì 2 lý do đó :D

-  Lỗi No_name: ".. từ line có layer "texttencoc" tìm không ra text chứa tên cọc "   : Ở đây, lisp tìm có quy luật: Tìm trong ô chọn hình chữ nhật phía End point của line Texttencoc; Ô chọn có kích thước xác định tại ......(get_text_coc x...

Lỗi xảy ra vẫn vì 2 lý do đó :D

(defun c:DONG5 ( / lst_va old ss_coc ss lst_name tim tlt tlp lst_ten_coc lst_coc mid_pnt ten find ob trai phai mid_pt fn pw)
;
(vl-load-com)
;
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nQuet chon BD de lay ten coc !")
(setq ss_coc (ssget '((0 . "LINE") (8 . "Texttencoc"))))
(if ss_coc 
	(progn
		(princ "\n Chon MEPTLT, MEPTLP, tim tuyen !")
		(setq ss (ssget '((8 . "MEPTLT,MEPTLP,TUYEN"))))
		(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(setq tim (car (vl-remove-if-not '(lambda(x) (= "TUYEN" (cdr (assoc 8 (entget x))))) lst_name))
			tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
			tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
		(command ".zoom" "o" ss_coc "")
		(setq	lst_ten_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_coc)))
				lst_ten_coc (mapcar '(lambda (x) (list x (get_text_coc x 6 13))) lst_ten_coc))
		(setq lst_coc (ssget "_F" (lst_point_fence tim) '((0 . "LINE") (8 . "ENTCOC"))))
		(setq lst_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex lst_coc))))
		(setq lst_coc 
			(mapcar 
				'(lambda (x) 
					(setq	mid_pnt (mid (vlax-curve-getStartpoint x) (vlax-curve-getEndpoint x))
							i 0)
					(while (< i (length lst_ten_coc))
						(if (setq find (find_piles (car (setq ten (nth i lst_ten_coc))) mid_pnt 35)) (setq i (length lst_ten_coc)) (setq i (1+ i)))
					)	   ;while
					(if find (list x mid_pnt (last ten)) (list x mid_pnt "No name"))
				)
				lst_coc)
		)
		(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
		(setq pw (open fn "w"))
		(write-line "STT,Ten coc,Trai,,,Phai" pw)
		(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
		(foreach c lst_coc
			(setq 	mid_pt (cadr c)
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(command "_.insert" "cocmoc" trai 1 "" "")
			(command "_.insert" "cocmoc" phai 1 "" "")
			(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
			(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
			(write-line (strcat "," (last c) "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
		)
		(close pw)
	)
	(princ "\nKhong chon duoc line ten coc !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;==============================================================
(defun mid (p1 p2) (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
;;;;==============================================================
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)
;;;;===================================================================
(defun lst_point_fence (pl / info lst_bug lst_point i arc_len fence)
(setq	info (entget pl '("*"))
		lst_bug (vl-remove-if-not '(lambda(x) (= 42 (car x))) info)
		lst_point (vl-remove-if-not '(lambda(x) (= 10 (car x))) info)
		i 0)
(while (< i (length lst_bug))
	(cond 
		((/= 0 (cdr (nth i lst_bug)))
			(setq	fence (cons (cdr (nth i lst_point)) fence)
					arc_len (abs (- (setq start (vlax-curve-getDistAtPoint pl (cdr(nth i lst_point)))) (vlax-curve-getDistAtPoint pl (cdr (nth (setq i (1+ i)) lst_point)))))
					
			)
			(repeat 3 
				(setq 	fence (cons (vlax-curve-getPointAtDist pl (setq start (+ start (/ arc_len 4)))) fence))
			)
		)
		(t (setq 
				fence (cons (cdr (nth i lst_point)) fence)
				i (1+ i))
		)
	)
)
(reverse fence)
)
;;;===============================================================
(defun get_text_coc (ent h w / info dau_line cuoi_line pt1 pt2 pt3 pt4 ss)
;ham lay text ten coc thuoc layer "Texttencoc" khi co line vach chi gan text
;h, w: chieu cao, rong cuar window vung chon
(setq	dau_line (cdr (assoc 10 (setq info (entget ent))))
		cuoi_line (cdr (assoc 11 info))
		pt1 (polar cuoi_line (+ (setq ang_line (angle dau_line cuoi_line)) (* 0.5 pi)) (* 0.5 w))
		pt2 (polar pt1 ang_line h)
		pt3 (polar pt2 (- ang_line (* 0.5 pi)) w)
		pt4 (polar cuoi_line (- ang_line (* 0.5 pi)) (* 0.5 w))
)
(setq ss (ssget "_WP" (list pt1 pt2 pt3 pt4) '((0 . "TEXT") (8 . "Texttencoc"))))
(if ss (cdr (assoc 1 (entget (ssname ss 0)))) "No_name")
)
;;;===================================================================
(defun find_piles (line_piles_name pnt_piles lim / st end)
;Tu line ten coc, tim thay point tim coc trong gioi han khoang cach (dien ten coc)
(setq	st (vlax-curve-getStartpoint line_piles_name)
		end (vlax-curve-getEndpoint line_piles_name))
(if (and (<= (distance end pnt_piles) lim) (or (equal (angle end st) (angle end pnt_piles) 7e-3) (equal pi (abs (- (angle end st) (angle end pnt_piles))) 7e-3))) T)
)

Nhờ các bác chỉ giáo sửa em 1 chút để hoàn thiện việc tăng tốc độ được không ạ?

Vì không chỉ bài toán nhỏ này mà em có kế hoạch nâng cấp hết lại các chương trình em viết. Vì đa số em hay dùng Append, chương trình chạy rất chậm nên đôi khi em thất vọng. Em cảm ơn các bác nhiều.

P/s: Em vọc được cả 2 cách bác @Phamthanhbinh và bác @Doan Van Ha rồi

>>

Update DONG5 >>> DONG6:

- Thay command bằng entmake

- Fix lỗi hàm lst_point_fence cho trường hợp có điểm trùng (như trên)

- Duyệt list bằng foreach ... thay cho while+nth ...

- Thêm cột K/c lẻ

....

p/s:

@ndtnv: Nếu mà thay WP bằng F hay CP thì xác suất chọn được tên cọc cao hơn nhưng phải xữ lý khá nhiều mà chưa chắc đã "toàn vẹn"

>>> Thôi...

Update DONG5 >>> DONG6:

- Thay command bằng entmake

- Fix lỗi hàm lst_point_fence cho trường hợp có điểm trùng (như trên)

- Duyệt list bằng foreach ... thay cho while+nth ...

- Thêm cột K/c lẻ

....

p/s:

@ndtnv: Nếu mà thay WP bằng F hay CP thì xác suất chọn được tên cọc cao hơn nhưng phải xữ lý khá nhiều mà chưa chắc đã "toàn vẹn"

>>> Thôi thì bác cho mình bảo lưu vậy :D :D :D

(defun c:DONG6 ( / lst_va old ss_coc ss lst_name tim tlt tlp lst_ten_coc lst_coc mid_pnt ten ob trai phai mid_pt fn pw c last_piles)
;
(vl-load-com)
;
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nQuet chon BD de lay ten coc !")
(setq ss_coc (ssget '((0 . "LINE") (8 . "Texttencoc"))))
(if ss_coc 
	(progn
		(princ "\n Chon MEPTLT, MEPTLP, tim tuyen !")
		(setq ss (ssget '((8 . "MEPTLT,MEPTLP,TUYEN"))))
		(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(setq tim (car (vl-remove-if-not '(lambda(x) (= "TUYEN" (cdr (assoc 8 (entget x))))) lst_name))
			tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
			tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
		(command ".zoom" "o" ss_coc "")
		(setq	lst_ten_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_coc)))
				lst_ten_coc (mapcar '(lambda (x) (list x (get_text_coc x 6 13))) lst_ten_coc))
		(setq lst_coc (ssget "_F" (lst_point_fence tim) '((0 . "LINE") (8 . "ENTCOC"))))
		(setq lst_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex lst_coc))))
		(setq lst_coc 
			(mapcar 
				'(lambda (x) 
					(setq	mid_pnt (mid (vlax-curve-getStartpoint x) (vlax-curve-getEndpoint x))
							ten "No name")
					(foreach elem lst_ten_coc
						(if (find_piles (car elem) mid_pnt 50) (setq ten (last elem)))
					)	   ;for
					(list x mid_pnt ten)
				)
				lst_coc)
		)
		(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
		(setq pw (open fn "w"))
		(write-line "STT,Ten coc,K/c le,Trai,,,Phai" pw)
		(write-line ",,,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
	;;xong tieu de
		(setq c (car lst_coc))
			(setq 	mid_pt (cadr c)
					last_piles mid_pt
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(Ket_insert "cocmoc" trai 1 0)
			(Ket_insert "cocmoc" phai 1 0)
			(make_dim_al mid_pt trai)
			(make_dim_al mid_pt phai)
			(write-line (strcat "," (last c) "," "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
	;xong dong 1	
		(foreach c (cdr lst_coc)
			(setq 	mid_pt (cadr c)
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(Ket_insert "cocmoc" trai 1 0)
			(Ket_insert "cocmoc" phai 1 0)
			(make_dim_al mid_pt trai)
			(make_dim_al mid_pt phai)
			(write-line (strcat "," (last c)"," (rtos (distance mid_pt last_piles) 2 3) "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
			(setq last_piles mid_pt)
		)
		(close pw)
	)
	(princ "\nKhong chon duoc line ten coc !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;==============================================================
(defun mid (p1 p2) (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
;;;;==============================================================
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)
;;;;===================================================================
(defun lst_point_fence (pl / info lst_bug lst_point i arc_len fence pre fence1)
(setq	info (entget pl '("*"))
		lst_bug (vl-remove-if-not '(lambda(x) (= 42 (car x))) info)
		lst_point (vl-remove-if-not '(lambda(x) (= 10 (car x))) info)
		i 0)
(while (< i (length lst_bug))
	(cond 
		((/= 0 (cdr (nth i lst_bug)))
			(setq	fence (cons (cdr (nth i lst_point)) fence)
					arc_len (abs (- (setq start (vlax-curve-getDistAtPoint pl (cdr(nth i lst_point)))) (vlax-curve-getDistAtPoint pl (cdr (nth (setq i (1+ i)) lst_point)))))
					
			)
			(repeat 3 
				(setq 	fence (cons (vlax-curve-getPointAtDist pl (setq start (+ start (/ arc_len 4)))) fence))
			)
		)
		(t (setq 
				fence (cons (cdr (nth i lst_point)) fence)
				i (1+ i))
		)
	)
)
(setq	pre (car fence)
		fence1 (list pre))
(foreach p (cdr fence)
	(cond ((not (equal 0 (distance p pre) 1e-3)) 
			(setq	fence1 (cons p fence1)
					pre p))
	)
)
fence1
)
;;;===============================================================
(defun get_text_coc (ent h w / info dau_line cuoi_line pt1 pt2 pt3 pt4 ss)
;ham lay text ten coc thuoc layer "Texttencoc" khi co line vach chi gan text
;h, w: chieu cao, rong cuar window vung chon
(setq	dau_line (cdr (assoc 10 (setq info (entget ent))))
		cuoi_line (cdr (assoc 11 info))
		pt1 (polar cuoi_line (+ (setq ang_line (angle dau_line cuoi_line)) (* 0.5 pi)) (* 0.5 w))
		pt2 (polar pt1 ang_line h)
		pt3 (polar pt2 (- ang_line (* 0.5 pi)) w)
		pt4 (polar cuoi_line (- ang_line (* 0.5 pi)) (* 0.5 w))
)
(setq ss (ssget "_WP" (list pt1 pt2 pt3 pt4) '((0 . "TEXT") (8 . "Texttencoc"))))
(if ss (cdr (assoc 1 (entget (ssname ss 0)))) "No_name")
)
;;;===================================================================
(defun find_piles (line_piles_name pnt_piles lim / st end)
;Tu line ten coc, tim thay point tim coc trong gioi han khoang cach (dien ten coc)
(setq	st (vlax-curve-getStartpoint line_piles_name)
		end (vlax-curve-getEndpoint line_piles_name))
(if (and (<= (distance end pnt_piles) lim) (or (equal (angle end st) (angle end pnt_piles) 7e-3) (equal pi (abs (- (angle end st) (angle end pnt_piles))) 7e-3))) T)
)
;;;===========================================================
(defun make_dim_al(pnt1 pnt2 / )
(setq lst
(list
	'(0 . "DIMENSION")
	'(100 . "AcDbEntity") 
	'(8 . "dim") 
	'(100 . "AcDbDimension") 
	(cons 10 pnt2) 
	(cons 11 (mid pnt1 pnt2))
	'(70 . 33) 
	'(1 . "") 
	'(100 . "AcDbAlignedDimension") 
	(cons 13 pnt1) 
	(cons 14 pnt2) 
))
(entmake lst)
)
;=============================================================
(defun Ket_insert (bname p s r)
;Insert simple static block
;Ten  point scale rotation
(entmake
	(list
		'(0 . "INSERT")      
		(cons 2 bname)
		(cons 10 p)
		(cons 41 s)(cons 42 s)(cons 43 s)      
		(cons 50 r)
	)	  ; list
)
)
;=======================

Rảnh nên làm thầy bói phát xem sao :D :D :D

;;;lisp danh so cot den
(defun c:SCD( / st str p chu str1)
(setq	#tu (NGT #tu "1" getstring "Tu chieu sang so")
		#lo (NGT #lo "1" getstring "Lo so")
		#st (NGT #st 1 getint "STT cot dau tien")
		st (1- #st)
		str (strcat "TCS" #tu "/L" #lo "/")
		)
(while
	(setq p (getpoint "\nPick: "))
	(setq chu (nth (rem st 3) '("A" "B" "C"))
		  st (1+ st)
		  str1 (strcat str (itoa st) chu)
		  )
	(MakeText p str1 2.5...
>>

Rảnh nên làm thầy bói phát xem sao :D :D :D

;;;lisp danh so cot den
(defun c:SCD( / st str p chu str1)
(setq	#tu (NGT #tu "1" getstring "Tu chieu sang so")
		#lo (NGT #lo "1" getstring "Lo so")
		#st (NGT #st 1 getint "STT cot dau tien")
		st (1- #st)
		str (strcat "TCS" #tu "/L" #lo "/")
		)
(while
	(setq p (getpoint "\nPick: "))
	(setq chu (nth (rem st 3) '("A" "B" "C"))
		  st (1+ st)
		  str1 (strcat str (itoa st) chu)
		  )
	(MakeText p str1 2.5 0 "L" nil nil 2 nil)
)
)
;;;==================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;;;=================================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================

Đây bạn:

;;;lisp danh so cot den
(defun c:SCD( / st str i p chu str1)
(setq    #tu (NGT #tu "1" getstring "Tu chieu sang so")
        #lo (NGT #lo "1" getstring "Lo so")
        #st (NGT #st 1 getint "STT cot dau tien")
        st (1- #st)
        str (strcat "TCS" #tu "/L" #lo "/")
        )
(initget "A B C")
(setq #pha (NGT #pha "A" getkword "Pha dau tien [A/B/C]"))
(cond ((= (strcase #pha) "A")
        (setq i -1)
    (while
        (setq p...
>>

Đây bạn:

;;;lisp danh so cot den
(defun c:SCD( / st str i p chu str1)
(setq    #tu (NGT #tu "1" getstring "Tu chieu sang so")
        #lo (NGT #lo "1" getstring "Lo so")
        #st (NGT #st 1 getint "STT cot dau tien")
        st (1- #st)
        str (strcat "TCS" #tu "/L" #lo "/")
        )
(initget "A B C")
(setq #pha (NGT #pha "A" getkword "Pha dau tien [A/B/C]"))
(cond ((= (strcase #pha) "A")
        (setq i -1)
    (while
        (setq p (getpoint "\nPick: "))
        (setq i (1+ i))
        (setq chu (nth (rem i 3) '("A" "B" "C"))
            st (1+ st)
            str1 (strcat str (itoa st) chu)
            )
        (MakeText p str1 2.5 0 "L" nil nil 2 nil)
    )
    )
    ((= (strcase #pha) "B")
        (setq i 0)
    (while
        (setq p (getpoint "\nPick: "))
        (setq i (1+ i))
        (setq chu (nth (rem i 3) '("A" "B" "C"))
            st (1+ st)
            str1 (strcat str (itoa st) chu)
            )
        (MakeText p str1 2.5 0 "L" nil nil 2 nil)
    )
    )
    ((= (strcase #pha) "C")
        (setq i 1)
    (while
        (setq p (getpoint "\nPick: "))
        (setq i (1+ i))
        (setq chu (nth (rem i 3) '("A" "B" "C"))
            st (1+ st)
            str1 (strcat str (itoa st) chu)
            )
        (MakeText p str1 2.5 0 "L" nil nil 2 nil)
    )
    )
)
)
;;;==================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
    ((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
    (modul)
    (a)
    )
    )
)
;;;=================================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial    
(setq Lst (list '(0 . "TEXT")
                (cons 8 (if Layer Layer (getvar "Clayer")))                                    
                (cons 62 (if Color Color 256))                                    
                (cons 10 point)                                    
                (cons 40 Height)                                    
                (cons 1 string)                                    
                (if Ang (cons 50 Ang))                                    
                (cons 7 (if Style Style (getvar "Textstyle")))                                    
                (cons -3 (if xdata (list xdata) nil)))                
                justify (strcase justify))    
                (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))                
                      ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))                
                      ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))                
                      ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))                
                      ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))                
                      ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))                    
                      ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))                
                      ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))                
                      ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))                
                      ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))                
                      ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))                
                      ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
                      )    
                      (entmakex Lst)
);end
;=================================