Cảm ơn Anh Tuệ rất nhiều. :bigsmile:

Đây là lisp đã đã được sửa để tính diện tích cả hình có lỗ khoét và không có...

>>

Cảm ơn Anh Tuệ rất nhiều. :bigsmile:

Đây là lisp đã đã được sửa để tính diện tích cả hình có lỗ khoét và không có lỗ khoét.

(defun c:bdt()(setvar "cmdecho" 0)(command "undo" "begin")(setq lacol (getvar "CEColor"))(setq ladin (getvar "dimzin"))(setq laos (getvar "osmode"))  (if (not tl) (setq tl 1))(if (not h) (setq h 1))(setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))    caot1 (getreal (strcat "\nCao text < " (rtos h 2 2) " >: ")))(if tl1 (setq tl tl1))(if caot1 (setq h caot1))(setq k 0 tdt 0)(setvar "dimzin" 0)(setvar "OSMODE" 0)(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))(setq 	P1 (list (+ (car PT)(* 6 h)) (cadr PT))    P2 (list (+ (car PT)(* 22 h)) (cadr PT))    P3 (list (car PT) (- (cadr PT)(* 3 h)))    P4 (list (car P1) (cadr P3))    P5 (list (car P2) (cadr P3))    P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))    P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))    P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h))));setq(command "pline" PT P2 P5 P3 "C"        "pline" P1 P4 ""        "text" "m" P6 (* 1.2 h) 0 "%¶ng thèng kª diÖn tÝch"        "text" "m" P7 h 0 "STT"        "text" "m" P8 h 0 "DiÖn tÝch (m2)");command(setq pt1 (getpoint "\n Chon mien tinh dien tich : "))(while (/= pt1 nil)(command "erase" ss "")(setq k (+ 1 k))(command "TEXT" "m" pt1 (* 3 h) 0 (rtos k 2 0))(setq PT (list (car P3) (cadr P3))    P1 (list (+ (car PT)(* 6 h)) (cadr PT))    P2 (list (+ (car PT)(* 22 h)) (cadr PT))    P3 (list (car PT) (- (cadr PT)(* 3 h)))    P4 (list (car P1) (cadr P3))    P5 (list (car P2) (cadr P3))    P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))    P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))    P9 (list (car PT) (- (cadr P3)(* 3 h)))    P10 (list (car P1) (cadr P9))    P11 (list (car P2) (cadr P9))    P12 (list (car P7) (- (cadr P3)(* 1.5 h)))    P13 (list (car P8) (cadr P12))    );setq(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary(command "cecolor"4 "-boundary" pt1 "");; boundary(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary(setq cur frome	ss (ssadd) S 0)(while 	(not (eq cur toe));; chon cac doi tuong tu frome den toe	(setq cur (entnext cur) ss (ssadd cur ss))	(command "area" "S" "O" ss "" "")	(setq dt (getvar "area") S (+ S dt)));while(command "area" "A" "O" "L" "" "")(setq dt (getvar "area"))(setq S (* (+ S (* dt 2)) tl tl) tdt (+ s tdt))  (setvar "CEColor" lacol)(command "pline" PT P2 P5 P3 "C"     "pline" P1 P4 ""     "text" "m" P7 h 0 (rtos k 2 0)     "text" "m" P8 h 0 (rtos s 2 2))(setq pt1 (getpoint (strcat "\nTong dien tich = " (rtos tdt 2 3) "m2. chon mien do tiep theo..."))));while(command "erase" ss "")(setq ss nil)(setvar "DIMZIN" ladin)(command 	"pline" P3 P9 P11 P5 "C"        "pline" P10 P4 ""        "text" "m" P12 h 0 "Tæng"        "text" "m" P13 h 0 (rtos tdt 2 2));command(setvar "OSMODE" laos)(command "undo" "end")(setvar "cmdecho" 1))

 

@vantiteo: Mình đang bận quá, tranh thủ thời gian ngủ trưa để sửa lại lisp này cho mọi người thôi. bạn có thể xem lisp của anh Tuệ để tìm ra chỗ thiếu sót của bạn. lisp của anh Tuệ rất hay.

@xuandao0708: Bạn cần phân biệt tỷ lệ vẽ và tỷ lệ in nhé. lisp này yêu cầu nhập vào tỷ lệ vẽ vì chỉ có tỷ lệ vẽ mới ảnh hưởng trực tiếp đến kết quả tính toán. theo như bạn nói thì thì tỷ lệ 1/500 của bạn chính là tỷ lệ in của bản vẽ ra giấy. còn thực chất bản vẽ của bạn vẫn được vẽ với tỷ lệ 1/1. nghĩa là 1 đơn vị vẽ trong cad sẽ tương ứng với 1 đơn vị đo ngoài thực địa.

Chào bác Thaistreetz. Bác cho em hỏi chút ạ.

-Nếu em muốn phần tỷ lệ trong đoạn lisp này luôn là 1:1 thì em phải sửa thế nào ạ?

<<

46 phút trước, Ngo Van Tam đã nói:

Như tiêu đề em có nói em có...

>>

46 phút trước, Ngo Van Tam đã nói:

Như tiêu đề em có nói em có 1 Block thuộc tính có 2 thông số cần thay đổi và nó sẽ được nhập vào ở hộp thoại với key là dw và dh
Ở block thuộc tính có tên BIEN DANG em cũng để 2 thông số này là DW và DH
các bác vui lòng xem hình ảnh đính kèm
Vậy autolisp có thể chèn được block thuộc tính này vào 1 điểm em cho trước là điểm pstart và tự cập nhật 2 thông số DW và DH ứng với dw và dh nhập vào ở hộp thoại không ạ
Nếu được các bác có thể code giúp em đoạn code này đc không ạ
em xin chân thành cảm ơn.

(defun C:Cbl (/ acdoc acspc)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
		acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace)))
(While (setq pstart (getpoint "/nPick diem dat: "))
(vla-InsertBlock acspc (vlax-3D-point pstart) "BIENDANG" 1 1 1 0)
)
)

sau đó bạn dùng lệnh TEXTEDIT để sửa giá trị tag nhé

<<

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua gia tri attdef block
;;;Cu phap su dung (duy:block_s_att dchon ten giatri)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:block_s_att (dchon ten giatri / dchon ten giatri Ent)
(setq capnhat dchon)
(while (/= (cdr (assoc 0 (entget (entnext dchon)))) "SEQEND")
(setq ent (entget...
>>

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua gia tri attdef block
;;;Cu phap su dung (duy:block_s_att dchon ten giatri)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:block_s_att (dchon ten giatri / dchon ten giatri Ent)
(setq capnhat dchon)
(while (/= (cdr (assoc 0 (entget (entnext dchon)))) "SEQEND")
(setq ent (entget (entnext dchon)))
(cond
((= (cdr (assoc 2 ent)) ten) 	  
(setq Ent (subst (cons 1 giatri) (assoc 1 ent) ent)) 
(entmod ent) ) 
)
(setq dchon (entnext dchon))
)
(command ".move" capnhat "" "_non" (list 0 0 0) "_non" (list 0 0 0))  
)
;;;;;;;;;;;;;;;;;;
(defun c:chenthu ()
(setq pstart (getpoint "Diem chen !"))
(command ".insert" "BIEN DANG" "_non" pstart 1 1 0)
(setq dtc (entlast))
(duy:block_s_att dtc "DW" "RONG")
(duy:block_s_att dtc "DH" "CAO")
(princ))

Trong này có 1 hàm dùng sửa giá trị của att trong block theo tên tag và 1 lệnh chèn block tên BIEN DANG tại điểm chịn sau đó sửa att DW thành "rong" và DH thành "cao". 2 giá trị này bạn đọc trong block hay lấy ở đây thì tuỳ bạn. Ưng sửa thành gì thì gỏ vào là xong.

- vuông góc thì được, song song mình chưa nghĩ ra ^^

(defun c:KKK(/ ent ss ds_ip ds_text ss2 ds_li ss3 en)
(setvar 'osmode 0)
(setvar 'cmdecho 0)
(setq ent (car (entsel "\nChon pline cho truoc: ")))
(alert "chon point")
(setq ss (ssget '((0 . "POINT"))))
(if (and ss ent)
	(progn
		(setq ds_text (ss2ent ss))
		(setq ds_ip (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) ds_text))
		(foreach k ds_ip...
>>

- vuông góc thì được, song song mình chưa nghĩ ra ^^

(defun c:KKK(/ ent ss ds_ip ds_text ss2 ds_li ss3 en)
(setvar 'osmode 0)
(setvar 'cmdecho 0)
(setq ent (car (entsel "\nChon pline cho truoc: ")))
(alert "chon point")
(setq ss (ssget '((0 . "POINT"))))
(if (and ss ent)
	(progn
		(setq ds_text (ss2ent ss))
		(setq ds_ip (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) ds_text))
		(foreach k ds_ip (lpp2c k ent "duong_giong"))
		;-----------------------------------------------------
		(setq ss2 (ssget "X" '((8 . "duong_giong"))))
		(if ss2 
			(progn
				(setq ds_li (ss2ent ss2))
				(foreach k ds_li
					(setq dx10 (cdr (assoc 10 (entget k))) dx11 (cdr (assoc 11 (entget k))))
					(setq ss3 (ssget "F" (list dx10 dx11) '((8 . "Level 10"))))
					(setq en (ssname ss3 0))
					(lpp2c dx10 en "chi_giong")
					(vl-cmdf ".extend" ent "" (entlast) "")
					(vl-cmdf ".erase" k "")
				)
				(vl-cmdf "-purge" "layer" "duong_giong" "n")
			)
		);end if ss2		
	)
)
(setvar 'cmdecho 1)
(princ)
)	

(defun LPP2C (p1 c lay / p2);;;Line from Point p1 Perpendicular To Curve c
(vl-load-com)
(setq p2 (vlax-curve-getClosestPointTo c p1 T))
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 (if lay lay)) ))
)
;==================
(defun ss2ent (ss / i Le e);;;Convert ss to list of ename
(setq i 0)
(repeat (sslength ss)
(setq e (ssname ss i)
Le (append Le (list e))
i (1+ i)    ))
Le)
;===================

Cái này vẽ song song:

 - chọn 1 pline cho truoc (pline mau xanh)

- Chọn các các text, mtext, block hoặc point cần vẽ

- chọn các LINE là canh của khu đất để định hướng vẽ song song

(defun c:lss (/ ent ss spar p1 lsdis enpar ang l1 pt)
  (setq ent (car (entsel "\nChon pline cho truoc: ")))
  (princ"\nChon cac TEXT, MTEXT, BLOCK, POINT")
 ...
>>

Cái này vẽ song song:

 - chọn 1 pline cho truoc (pline mau xanh)

- Chọn các các text, mtext, block hoặc point cần vẽ

- chọn các LINE là canh của khu đất để định hướng vẽ song song

(defun c:lss (/ ent ss spar p1 lsdis enpar ang l1 pt)
  (setq ent (car (entsel "\nChon pline cho truoc: ")))
  (princ"\nChon cac TEXT, MTEXT, BLOCK, POINT")
  (setq ss (ssget '((0 . "*text,insert,point"))))
  (princ"\nChon cac LINE canh khu dat de ve song song")
  (setq spar (ssget '((0 . "line"))))
  (if (and ss ent spar)
    (progn
      (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq spar (vl-remove-if 'listp (mapcar 'cadr (ssnamex spar))))
      (foreach k ss
	(setq p1 (dxf 10 k))
	(setq lsdis (vl-sort spar '(lambda (x y) (< (dis p1 x) (dis p1 y)))))
	(setq enpar (car lsdis))
	(setq ang (angle (dxf 10 enpar) (dxf 11 enpar)))
	(setq l1 (vlax-ename->vla-object (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 (polar p1 5 ang))(cons 62 2)))))
	(setq pt (vlax-invoke l1 'IntersectWith (vlax-ename->vla-object ent) acExtendBoth))
	(vla-put-EndPoint l1 (vlax-3d-point pt))
	)
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun
(defun dis (p en)
  (distance p (vlax-curve-getClosestPointTo en p T))
  )
(defun DXF (code ent) (cdr (assoc code (entget ent))))

 

Bạn thử cái này xem:

(defun c:rd () (setvar 'SNAPANG 0) (princ))
(defun c:rs  (/ pt1 pt2)
 (and...
>>

 

Bạn thử cái này xem:

(defun c:rd () (setvar 'SNAPANG 0) (princ))
(defun c:rs  (/ pt1 pt2)
 (and (setq pt1 (getpoint "\nFirst point: "))
      (setq pt2 (getpoint pt1 "\nSecond point: "))
      (setvar 'SNAPANG (angle pt1 pt2)))
 (princ))

em thử rồi sao khồng được nhỉ, anh có thể xem lại được không.em cảm ơn anh

<<

Download lisp

Filename: 402746_rd_rs%C2%A0.lsp

Để sửa các gtrị kích thước trong bản vẽ chúng ta thường dùng lệnh edit. Sửa nhiều đường KT cùng 1 giá trị thì dùng lệnh DIMEDIT nhưng phải lựa chọn biến N (New) thật...

>>

Để sửa các gtrị kích thước trong bản vẽ chúng ta thường dùng lệnh edit. Sửa nhiều đường KT cùng 1 giá trị thì dùng lệnh DIMEDIT nhưng phải lựa chọn biến N (New) thật phiền phức. Đoạn LISP sau khắc phục điều đó (chỉ cần nhập giá trị, sau đó chọn các dường KT là OK).

Command:DE

 

(defun c:DE ()
(PRINC "dgqcc")
(command "DIMEDIT" "N")
(princ)
)

Tinh thần của mình là cái gì cad có thì xài, không mới dùng lisp, đừng lạm dụng.

Cách sửa của bạn có thể làm như sau :

- Chọn tất cả các dim muốn sửa.

- Ctrl + 1 để gọi bảng Properties.

- Tìm dòng Text override, nhập số muốn sửa.

Các này áp dụng được cho việc thay đổi đồng loạt các thuộc tính giống nhau của các đối tượng khác nhau

<<

4 giờ trước, AUTOCAD_2019 đã nói:

em hiểu ý anh r để lần...

>>

4 giờ trước, AUTOCAD_2019 đã nói:

em hiểu ý anh r để lần sau em sẽ làm vậy ạ

(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
  (vl-load-com)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
  (setvar 'cmdecho 0)
    (setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
  (mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (command "-LAYER" "M" x "" "")) ) lstl)
  (foreach ent ss
    (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
    (setq ss1 (acet-ss-to-list (acet-explode ent)))
    (setq ss1 (vl-sort ss1 '(lambda (x y) (cond	( (= (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))) )
					    (< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y))))))
					     ((> (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget  y))))))  ))))
    (setq lst (list))
    (while (setq en (car ss1))
      (setq ss1 (cdr ss1))
      (setq lst2 (list en))
      (while (and (setq en2 (car ss1))
		  (= (cadr (cdr (assoc 10 (entget en)))) (cadr (cdr (assoc 10 (entget en2)))) ) )
	(setq ss1 (cdr ss1))
	(setq lst2 (append lst2 (list en2)))
	)
      (if (> (length lst2) 1) (progn
	(setq str "")
	(mapcar '(lambda (x) (setq str (strcat str (cdr (assoc 1 (entget x)))))) lst2)
	(setq en3 (car lst2))
	 (mapcar '(lambda (x) (entdel x) ) (cdr lst2))
	(entmod (subst (cons 1 str) (assoc 1 (entget en3)) (entget en3)))
	(setq lst (append lst (list en3)))
	) (setq lst (append lst lst2)))
      )
    (if (= (length lst) 5) (progn
			     (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
			     (mapcar '(lambda (x y) (vla-put-layer (vlax-ename->vla-object x) y)) lst lstl))
      (progn
	(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
	(command "UNDO" "1")))
    )
  (setvar 'cmdecho 1)
  (princ)
  )

Viết cho bạn luôn đây 

<<

Cám ơn bác hoành, rất đúng ý em! Em dang cần 1 lisp nữa có nội dung sau: gọi là lisp explore đối tượng có thickness,

VD: trên màn hình là 1 line có thickness là 10, chiều dài 8...

>>

Cám ơn bác hoành, rất đúng ý em! Em dang cần 1 lisp nữa có nội dung sau: gọi là lisp explore đối tượng có thickness,

VD: trên màn hình là 1 line có thickness là 10, chiều dài 8 (nhìn trong 3D sẽ là 1 hình chữ nhật). tuy nhiên lệnh explore không có tác dụng với đối tượng này, có anh nào có lisp có thể explore đối tượng ra thành 4 line riêng rẽ không? em cám ơn!

Lệnh EXPL (Explode Line) dưới đây sẽ làm điều bạn muốn.

 

(defun c:expl()
 (princ "\nExplode lines with thickness to Lines - free lisp from CADViet.com")  
 (sudung exponeline (ssget '((0 . "LINE")(-4 . ""))))
 (princ)
)

(defun exponeline(ent)  
 (setq
   tt (entget ent)
   p1 (cdr (assoc 10 tt))
   p2 (cdr (assoc 11 tt))
   vt (cdr (assoc 210 tt))
   cao (cdr (assoc 39 tt))
   a (car vt)
   b (cadr vt)
   c (caddr vt)
   xf (* (/ a (+ a b c)) cao)
   yf (* (/ b (+ a b c)) cao)
   zf (* (/ c (+ a b c)) cao)
   p3 (list
 (+ (car p2) xf)
 (+ (cadr p2) yf)
 (+ (caddr p2) zf)
      )
   p4 (list
 (+ (car p1) xf)
 (+ (cadr p1) yf)
 (+ (caddr p1) zf)
      )
   tt (vl-remove (assoc 11 tt) (vl-remove (assoc 10 tt) (subst (cons 39 0.0) (assoc 39 tt) tt)))
 )
 (entmod (append tt (list (cons 10 p1)(cons 11 p2))))
 (entmake (append tt (list (cons 10 p1)(cons 11 p4))))
 (entmake (append tt (list (cons 10 p2)(cons 11 p3))))
 (entmake (append tt (list (cons 10 p3)(cons 11 p4))))
)

(defun sudung (ham ss / sodt index entdt soapp)
 (setq	sodt  (if ss (sslength ss) 0)
soapp 0
index 0
 )
 (repeat sodt
   (setq entdt	(ssname ss index)
  index	(1+ index)
   )
   (if	(ham entdt)
     (setq soapp (1+ soapp))
   )
 )
 soapp
)
(princ "\nExplode Line - free lisp from CADViet.com")
(princ "\nPlease use EXPL to use this command")
(vl-load-com)

<<

Chương trình ghi tọa độ tâm đường tròn và ghi kích thước kiểu xxxx/2 = yyy:

 

>>

Chương trình ghi tọa độ tâm đường tròn và ghi kích thước kiểu xxxx/2 = yyy:

 

;;;-------------------------------------------------------------------------------
(defun wtxthp (txt h p / sty d h) ;;;Write txt with 3 parameters
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p)
                              (if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)
;;;-------------------------------------------------------------------------------
(defun cc1(e dx dy / d p x y pt) ;;;Coordinate of 1 Circle
(setq
   d (entget e)
   p (trans (cdr (assoc 10 d)) 0 1)
   x (car p) y (cadr p)
   pt (trans (list (+ x dx) (+ y dy)) 1 0)
)
(wtxthp (strcat "x=" (rtos x) "; y=" (rtos y)) h pt)
)
;;;-------------------------------------------------------------------------------
(defun C:CC() ;;;Coordinate of Circles
(if (null h0) (setq h0 2.5))
(setq
   ss (ssget '((0 . "CIRCLE")))
   h (getreal (strcat "\nText height <" (rtos h0) ">:"))
   oldos (getvar "osmode")
)
(if (null h) (setq h h0) (setq h0 h))
(setvar "osmode" 0)
(while (setq e (ssname ss 0))
   (cc1 e (/ h 2) (/ h 2))
   (ssdel e ss)
)
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------
(defun C:DD( / ss e d v oldtxt newtxt d2) ;;;convert Dimensions to Divided format
(setq ss (ssget '((0 . "DIMENSION"))))
(while (setq e (ssname ss 0))
   (setq
       d (entget e)
       v (cdr (assoc 42 d))
       oldtxt (assoc 1 d)
       newtxt (cons 1 (strcat (rtos (* v 2)) "/2=<>"))
       d2 (subst newtxt oldtxt d)
   )
   (entmod d2)
   (ssdel e ss)
)
(princ)
)
;;;-------------------------------------------------------------------------------
(defun C:XDD(/ p1 p2 x txt) ;;;make X Dimension by Divided format
(setq
   p1 (getpoint "\nFirst point:")
   p2 (getpoint p1 "\nSecond point:")
   x (abs (- (car p1) (car p2)))
   txt (strcat (rtos (* x 2)) "/2=<>")
)
(command "dimlinear" p1 p2 "h" "m" txt pause)
)
;;;-------------------------------------------------------------------------------
(defun C:YDD(/ p1 p2 y txt) ;;;make Y Dimension by Divided format
(setq
   p1 (getpoint "\nFirst point:")
   p2 (getpoint p1 "\nSecond point:")
   y (abs (- (cadr p1) (cadr p2)))
   txt (strcat (rtos (* y 2)) "/2=<>")
)
(command "dimlinear" p1 p2 "v" "m" txt pause)
)
;;;-------------------------------------------------------------------------------

 

Có 4 lệnh:

CC, Coordinate of Circles

DD, convert Dimensions to Divided format.

XDD, make X Dimension by Divided format

YDD, make Y Dimension by Divided format

 

Chú ý:

Lệnh convert DD áp dụng cho mọi đối tượng dimension nhưng các lệnh make chỉ áp dụng cho dimlinear và buộc phải chia thành 2 lệnh XDD và YDD. Lý do: dù có xử lý gì đi nữa, cuối cùng chương trình vẫn phải gọi lệnh dimlinear. Sau khi pick 2 điểm, người dùng có thể tùy ý chọn dim theo phương ngang hoặc thẳng đứng, cái đó nằm ngoài tầm kiểm soát của chương trình nên phải quy định rõ ràng ngay từ đầu! Đã làm đầy đủ theo ý bạn, nhưng theo quan điểm của mình, bạn cứ đánh dim bình thường, sau đó dùng DD cho tất cả các dim muốn convert. Chỉ 1 lần là OK ngay.

 

Đã đúng ý của em rồi, lần sau em sẽ rút kinh nghiệm khi gửi bài yêu cầu lên diễn đàn. Em chân thành cám ơn bác SSG nhé.

 

Nhân tiện cho em hỏi: Ở phiên bản AutoCad R14 có lệnh "ctrl + a" là lệnh Group on/off. Vậy ở phiên bản AutoCad 2007 nó là lệnh gì vậy các bác

<<

Lệnh là JD (Joint các Điểm).

 

Chương trình yêu cầu bạn nhập các đối tượng vào (lẫn lộn cả point và text). Chương trình tự phân biệt đâu là point,...

>>

Lệnh là JD (Joint các Điểm).

 

Chương trình yêu cầu bạn nhập các đối tượng vào (lẫn lộn cả point và text). Chương trình tự phân biệt đâu là point, đâu là tên điểm và đâu là code rồi thực thi như yêu cầu của bạn.

 

Text không cần trùng điểm chèn với point mà chỉ cần gần point là chương trình nhận biết được.

 

(defun c:jd ()
 (setq
   ss         (ssget
	 '((-4 . "<OR")
	   (-4 . "<AND")(0 . "POINT") (8 . "DIEM")(-4 . "AND>")
	   (-4 . "<AND")(0 . "TEXT") (8 . "TENDIEM")(-4 . "AND>")
	   (-4 . "<AND")(0 . "TEXT") (8 . "CODE")(-4 . "AND>")
	   (-4 . "OR>")
	  )
       )
   lstent     (ss2ent ss)

   lsttendiem (mapcar '(lambda	(e)
		  (cons	(cdr (assoc 10 (entget e)))
			(cdr (assoc 1 (entget e)))
		  )
		)
	       (filter lstent "TEXT" "TENDIEM")
       )
   lstcode    (mapcar '(lambda	(e)
		  (cons	(cdr (assoc 10 (entget e)))
			(cdr (assoc 1 (entget e)))
		  )
		)
	       (filter lstent "TEXT" "CODE")
       )
   lstpoint   (mapcar '(lambda (e) (cdr (assoc 10 (entget e))))
	       (filter lstent "POINT" "DIEM")
       )
   lstpoint   (mapcar '(lambda	(p)
		  (cons (timgan p lsttendiem) p)
		)
	       lstpoint
       )
 )
 (foreach pp lstcode
   (setq
     pc       (car pp)
     tendiem (timgan pc lsttendiem)
     code    (cdr pp)
     p       (cdr (assoc tendiem lstpoint))      
     lstc (explode (substr code 2) "-")
   )

   (foreach cc	lstc
     (setq f (assoc cc lstpoint))
     (if f
(progn
  (setq p0 (cdr f))
  (makeline p0 p)
)
     )
   )
 )

 (princ)
)
 (defun timgan	(p lst / dmin ppluu)
   (foreach pp	lst
     (setq d (distance p (car pp)))
     (if (or (not dmin) (> dmin d))
(setq
  dmin d
  ppluu	pp
)
     )
   )
   (cdr ppluu)
 )

(defun filter(lstent otype olayer / kq)
 (foreach pp lstent
    (setq tt (entget pp))
    (if (and
   (member (cons 0 otype) tt)
   (member (cons 8 olayer) tt)
 )
      (setq kq (append kq (list pp)))
    )
 )
 kq
)

(defun pos (sub st / l1 l2 index)
 (setq	index 1
l1    (strlen sub)
l2    (strlen st)
 )
 (while
   (and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
    (setq index (1+ index))
 )
 (if (= sub (substr st index l1))
   index
   nil
 )
)

(defun explode (str sep / kq)
 (setq kq nil)
 (while (setq vt (pos sep str))
   (setq
     kq  (append kq (list (substr str 1 (1- vt))))
     str (substr str (1+ vt))
   )
 )
 (setq kq (append kq (list str)))
 kq
)

(defun makeline	(p1 p2)
 (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)

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

Xin phép Bác Hoành cho tôi được thêm đọan mã sau vào cái lisp Bác đã viết: (command "layer" "M" "lines" nill)

để đối tượng lines tạo ra luôn nằm trên Layer "LINES", cho nó đâu ra đấy, anh em sử dụng lisp này đỡ vất vả

Bác Hòanh cho hỏi thêm chút nhé! Có khi nào các điểm nằm gần nhau bị nối nhầm không Bác ? Nếu Point là 3D có thực hiện được không ?

Hình như cái Lisp này nó không chịu chơi vơí thằng Cad R14 Bác a! Khổ nỗi máy mình xưa quá, mấy Thằng Cad đời hậu sinh nó không hạp

<<

Nhờ các Pro xem sửa giúp em cái líp này với. đây là 1 đoạn lisp mình copy trong chương trình Fascad

 

;VE LUOI COT
(defun c:LC ()
(setq hstl 1)
(setq om...
>>

Nhờ các Pro xem sửa giúp em cái líp này với. đây là 1 đoạn lisp mình copy trong chương trình Fascad

 

;VE LUOI COT
(defun c:LC ()
(setq hstl 1)
(setq om (getvar "osmode"))
...

Bạn thêm vào 1 dòng (setq hstl 1) sau dòng (defun c:LC() như trên.

<<

Bạn chỉ cần xoá tất cả các ký tự liên quan đến PT5, PT6 và xoá hết các chữ "A" trong đoạn mã trên là chương trình sẽ trở thành như bạn muốn. Và đây là...

>>

Bạn chỉ cần xoá tất cả các ký tự liên quan đến PT5, PT6 và xoá hết các chữ "A" trong đoạn mã trên là chương trình sẽ trở thành như bạn muốn. Và đây là đoạn mã sau khi xoá:

;*******************************************************************************

(defun myerror (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)
;*******************************************************************************

(DEFUN C:TD (/ OLDERR CMD OSM DK PT1 PT2 PT3 PT4 PT5 PT6 STR PRPT GOCX GOCY
PTD PTC)
(SETQ OLDERR *error*
*error* myerror)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETVAR "CMDECHO" 0)
(SETQ DK (GETVAR "USERR3"))
(IF (= DK 0)
(PROGN
(SETQ STR "1")
(SETVAR "USERR3" 1)
)
(SETQ STR (RTOS DK))
)
(SETQ PRPT (STRCAT "khoang cach moc <" STR ">:"))
(SETQ DK (GETREAL PRPT))
(IF (= DK NIL)
(SETQ DK (GETVAR "USERR3"))
(SETVAR "USERR3" DK)
)
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETVAR "OSMODE" 0)
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(SETQ PT1 (POLAR PTD GOCX (/ DK 2)))
(SETQ PT2 (POLAR PTC (+ GOCX PI) (/ DK 2)))
(SETQ PT3 (POLAR PT1 GOCY DK))
(SETQ PT4 (POLAR PT2 GOCY DK))
(COMMAND "PLINE" PT3 PT1 PT2 PT4 "")
(SETVAR "OSMODE" OSM)
(SETVAR "CMDECHO" CMD)
(PRINC)
)

Lisp trên em chưa thử được nhưng cũng xin cảm ơn bác rất nhiều! Thanks bác 1 cái mà vẫn chưa thấy đủ. Chúc bác một năm mới may mắn, mạnh khoẻ!

<<

(defun c:TU ( / ob str p1 h style)
(setq ob (vlax-ename->vla-object (car (entsel "\n Chon dim:"))))
(setq str (rtos (vla-get-Measurement ob) 2 0)
style (vla-get-TextStyle ob)
h (* (vla-get-TextHeight ob) (vla-get-ScaleFactor ob) 0.75)
p1 (getpoint "\nDiem dat text:"))
(command "_txt2mtxt" (entmakex (list (cons 0 "text") (cons 10 p1) (cons 7 style) (cons 40 h) (cons 1 str))) "")
)

-  mình sửa...

(defun c:TU ( / ob str p1 h style)
(setq ob (vlax-ename->vla-object (car (entsel "\n Chon dim:"))))
(setq str (rtos (vla-get-Measurement ob) 2 0)
style (vla-get-TextStyle ob)
h (* (vla-get-TextHeight ob) (vla-get-ScaleFactor ob) 0.75)
p1 (getpoint "\nDiem dat text:"))
(command "_txt2mtxt" (entmakex (list (cons 0 "text") (cons 10 p1) (cons 7 style) (cons 40 h) (cons 1 str))) "")
)

-  mình sửa lại cho ra thẳng mtext 

Nếu cái lisp tạo từ cái txt của thớt vẽ ra bản cad là đúng thì lisp này của tôi đã coi là đúng rối đây vì dùng lisp của tôi nó vẻ ra được y chang vây rồi. Đáp ứng được yêu cầu của chủ thớt. 

Tiếc là tôi không dám lấy nó cho vào lisp của tôi vì tôi thấy hơi không có niềm tin. Dừng ở đây nhé thớt đả được cái đúng theo yêu cầu rồi đó.

Nếu cái lisp tạo từ cái txt của thớt vẽ ra bản cad là đúng thì lisp này của tôi đã coi là đúng rối đây vì dùng lisp của tôi nó vẻ ra được y chang vây rồi. Đáp ứng được yêu cầu của chủ thớt. 

Tiếc là tôi không dám lấy nó cho vào lisp của tôi vì tôi thấy hơi không có niềm tin. Dừng ở đây nhé thớt đả được cái đúng theo yêu cầu rồi đó.

(defun STR-NUMBER (str / LST LST1 LST2)
(setq lst (vl-string->list str))
(SETQ LST1 (LIST))
(while (setq X (car LST))
(setq LST (CDR LST))
(SETQ LST2 (LIST))
(IF (AND (>= X 48) (<= x 57)) (PROGN (SETQ LST2 (APPEND LST2 (LIST X)))
(WHILE (AND (>= (car LST) 48) (<= (car LST) 57))
(SETQ LST2 (APPEND LST2 (LIST (car LST))))
(SETQ LST (CDR LST))
)
(SETQ LST1 (APPEND LST1 (LIST LST2)))
))
)
(MAPCAR '(LAMBDA (X) (vl-list->string X)) LST1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao file chua noi dung list  
;;;Cu phap su dung (duy:taotxt<list filename listtc) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:taotxt<list (filename listtc / filename tapchon dtc)
(setq ndd (open filename "w"))
(foreach dtc listtc
(write-line dtc ndd)
)
(close ndd)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao list chua noi dung file
;;;Cu phap su dung (duy:taolist<f tenfile) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:taolist<f (filename / filename)
(setq lkq nil)
(setq ndd (open filename "r"))
(while 
(/= nil (setq ddd (read-line ndd)))
(setq lkq (append lkq (list ddd)))
)
(close ndd)
lkq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ftp ()
(cond
((= toadomay nil) (setq toadomay (list 0 0 0)) )
)

(setq filedo (getfiled "Chon file so lieu" "" "txt" 0))
(setq ndfiledo (duy:taolist<f filedo))

(foreach nddongdo ndfiledo
(setq tachnd (STR-NUMBER nddongdo))
(setq soluong (length tachnd))

(cond
((= soluong 6) (gandiemgoc))
((= soluong 4) (gandiemle))
)

)

(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gandiemgoc ()
(setq ttd 0)
(setq tm (nth 0 tachnd))
(setq sd (nth 1 tachnd))
(setq xg (atof(nth 2 tachnd)))
(setq yg (atof(nth 3 tachnd)))
(setq ag (atof(nth 4 tachnd)))
(setq zg (/ (atof (nth 5 tachnd)) 1))
(setq ddm (list xg yg))
(setq ddmz (list xg yg zg))
(entmake (list (cons 0 "TEXT")(cons 10 ddm)(cons 11 ddm)(cons 40 500)(cons 50 0)(cons 72 0)(cons 1 (rtos zg 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_text")(cons 62 256))) 
(entmake (list (cons 0 "POINT")(cons 10 ddmz)(cons 8 "layrekhac_point")(cons 62 256))) 
(entmake (list (cons 0 "TEXT")(cons 10 ddm)(cons 11 ddm)(cons 40 500)(cons 50 0)(cons 72 2)(cons 1 (strcat "tram may" tm))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_stt")(cons 62 256))) 
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gandiemle ()
(setq ttd (+ ttd 1))
(setq do (nth 0 tachnd))
(setq phut (nth 1 tachnd))
(setq chigiua (/ (atof (nth 2 tachnd)) 1))
(setq chiduoi (/ (atof (nth 3 tachnd)) 1))
(setq gocb (strcat do "d" phut "'" "00" "\""))
(setq gocb (- (/ PI 2) (angtof gocb 1) ))
(setq daib (* (- chigiua chiduoi) 200))
(setq caob (- zg chigiua))
(setq db (polar ddm gocb daib)) 
(setq dbz (list (car db) (cadr db) caob))
(setq tendiem (strcat tm "-" (rtos ttd 2 0)))
(entmake (list (cons 0 "TEXT")(cons 10 db)(cons 11 db)(cons 40 500)(cons 50 0)(cons 72 0)(cons 1 (rtos caob 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_text")(cons 62 256))) 
(entmake (list (cons 0 "POINT")(cons 10 dbz)(cons 8 "layrekhac_point")(cons 62 256))) 
(entmake (list (cons 0 "TEXT")(cons 10 db)(cons 11 db)(cons 40 500)(cons 50 0)(cons 72 2)(cons 1 tendiem)(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_stt")(cons 62 256))) 
)

Lệnh là FTP.

3 giờ trước, tinhcatn đã nói:

-- mình có bản vẽ mà cao độ POINT...

>>

3 giờ trước, tinhcatn đã nói:

-- mình có bản vẽ mà cao độ POINT bị sai không giống với cao độ TEXT. Nhờ các bạn giúp mình viết LISP mà cao độ POINT tự động lấy từ cao độ của TEXT gần nhất với

-- bản vẽ của mình có rất nhiều điểm nên không thể sửa tay được.

-- cám ơn các bạn

1.dwg

(defun c:te (/ ss ent)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "TEXT,POINT")))))
  (setvar 'cmdecho 0)
  (foreach ent ss
    (if (= (cdr (assoc 0 (entget ent))) "POINT") (entdel ent)(progn
	(vla-AddPoint (vla-get-modelspace (vla-get-activedocument 
                   (vlax-get-acad-object))) (vlax-3d-point (cdr (assoc 11 (entget ent)))))
	))
    )(setvar 'cmdecho 1)(princ))

Bạn test thử xem được chưa 

<<

Bạn thử cái này xem sao nhé.

;; free lisp from cadviet.com

;; free lisp from cadviet.com
(defun c:TLT ()
  (setq os (getvar "osmode"))
  (setq caochu (getreal "\nnhap cao chu: "))
  (setvar "osmode" 0)
(while (setq name (car (entsel "\nChon line can tinh do...
>>

Bạn thử cái này xem sao nhé.

;; free lisp from cadviet.com

;; free lisp from cadviet.com
(defun c:TLT ()
  (setq os (getvar "osmode"))
  (setq caochu (getreal "\nnhap cao chu: "))
  (setvar "osmode" 0)
(while (setq name (car (entsel "\nChon line can tinh do doc")))
  (setq ent (entget name))
(if (= (cdr (assoc 0 ent)) "LINE")
(progn
  (setq p (cdr (assoc 10 ent))
       p1 (cdr (assoc 11 ent)))
(if (> (car p) (car p1))
(progn
  (setq p (cdr (assoc 11 ent))
       p1 (cdr (assoc 10 ent)))
)
)
)
)
(if (= (cdr (assoc 0 ent)) "LWPOLYLINE")
(progn
  (setq listp (acet-geom-vertex-list name))
  (setq p (car listp)
       p1 (cadr listp))
(if (> (car p) (car p1))
(progn
  (setq p (cadr listp)
       p1 (car listp))
)
)
)
)
  (cond ((null tphan) (setq tphan 2)))
  (setq dau1 (car p))
  (setq cuoi1 (cadr p))
  (setq dau2 (car p1))
  (setq cuoi2 (cadr p1))
  (setq lx (abs (- dau1 dau2)))
  (setq ly (abs (- cuoi1 cuoi2)))
  (setq i (/ lx ly))
  (setq pt1 (polar p (angle p p1) (/ (distance p p1) 2)))
         (setq dau1 (+ 5 (car pt1)))
         (setq cuoi1 (cadr pt1))
         (setq goc (/ (* (angle p p1) 180) pi))
  (setq pt2 (polar pt1 (+ (angle p p1) (/ pi 2)) caochu))
         (setq chuoi (strcat "1/" (rtos i 2 tphan)))
         (command "text" "J" "M" pt2 caochu goc chuoi )
)
(setvar "osmode" os)         
)

 

Anh ơi có thể sửa hàm này giúp em Kết quả độ dốc tính ra % được không?

Em sửa mà nó bị lỗi.

<<

- Ấy quên angbase, angdir trong cad anh @duy782006 nó khác quy ước đo đạc ^^, phải qua trái, goc đầu là 0, cad là 90 nên mình phải lấy góc đo + 90, nhóc quỡn cũng viết thử, hàm thì mót chủ yếu, bỏ nghề lâu rùi nên tư duy giải thuật...

- Ấy quên angbase, angdir trong cad anh @duy782006 nó khác quy ước đo đạc ^^, phải qua trái, goc đầu là 0, cad là 90 nên mình phải lấy góc đo + 90, nhóc quỡn cũng viết thử, hàm thì mót chủ yếu, bỏ nghề lâu rùi nên tư duy giải thuật yếu rùi ^^

(defun LM:roundto ( n p )
    (LM:roundm n (expt 10.0 (- p)))
)
(defun LM:roundm ( n m )
    (* m (atoi (rtos (/ n (float m)) 2 0)))
)
;;ham tao text 3
(defun K_text (pt height string justify layer textstyle mau ang xdata / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 pt)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 50 (if ang ang 0))
							  (cons 8 (if layer layer (getvar 'clayer)))
							  (cons 7 (if textstyle textstyle (getvar 'textstyle)))
							  (cons 62 (if mau mau 256))
							  
			)
			justify (strcase justify))
			(if xdata (setq lst (append lst xdata)))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
				)
	(entmakex Lst)
  )	;end K:text
;;-------------------------
;-----------------------------------------------------------------
(defun s2d (str / ret)

  (setq ret

  (vl-list->string

	(vl-remove-if

  	'(lambda (x) (or (< x 48) (> x 57)))

  	(reverse (vl-string->list str))

	)

  )

  )

  (angtof

	(vl-list->string

			(reverse

					(vl-string->list

						(strcat "\"" (substr ret 1 2) "'" (substr ret 3 2) "d" (substr ret 5))

					)

			)

	)

  )

)
;=======================================================================
(defun K_readtxt ( txt del / des lst str )
    (if (setq des (open txt "r"))
        (progn
             (while (setq str (read-line des))
                (setq lst (cons (LM:txt->lst str del 0) lst))
            )
            (close des)
        )
    )
    (reverse lst)
)
;====================
(defun LM:txt->lst ( str sep pos / s )
    (cond
        (   (not (setq pos (vl-string-search sep str pos)))
            (if (wcmatch str "\"*\"")
                (list (LM:txt-replacequotes (substr str 2 (- (strlen str) 2))))
                (list str)
            )
        )
        (   (or (wcmatch (setq s (substr str 1 pos)) "\"*")
                (and (wcmatch s "~**") (= 1 (logand 1 pos)))
            )
            (LM:txt->lst str sep (+ pos 2))
        )
        (   (wcmatch s "\"*\"")
            (cons
                (LM:txt-replacequotes (substr str 2 (- pos 2)))
                (LM:txt->lst (substr str (+ pos 2)) sep 0)
            )
        )
        (   (cons s (LM:txt->lst (substr str (+ pos 2)) sep 0)))
    )
)

(defun LM:txt-replacequotes ( str / pos )
    (setq pos 0)
    (while (setq pos (vl-string-search  "\"\"" str pos))
        (setq str (vl-string-subst "\"" "\"\"" str pos)
              pos (1+ pos)
        )
    )
    str
)
;---------------
(defun MakePoint (point layer color)
(entmakex (list '(0 . "POINT")'(100 . "AcDbEntity")
								(cons 8 (if Layer Layer (getvar "Clayer")))
								(cons 62 (if Color Color 256))
								'(100 . "AcDbPoint")(cons 10 point))))
;=======================================================================================================
(defun c:k5 (/ base dir xdau ydau file S_data cdo_ngam ds_chitiet leng_chitiet phut k_phut canh goc x_k y_k cdo i)
(setvar 'cmdecho 0)
(setvar 'osmode 0)
(setq dir (getvar 'angdir))
(setvar 'angdir 1)
(setq xdau 0 ydau 0)
(if (setq file (getfiled "Select TXT File" "" "txt" 16))
	(progn
		(setq S_data (cdr (K_readtxt file "\t")))
		(setq cdo_ngam  (atoi (nth 5 (nth 0 S_data))))
		(setq ds_chitiet (cdr S_data))
		(setq leng_chitiet (length ds_chitiet))
		(setq i 1)
		(foreach k ds_chitiet
			(setq phut (nth 1 k))
			(if (= (strlen phut) 1)
				(setq k_phut (strcat "0" phut))
				(setq k_phut phut)
			)	
			(setq goc (+ (/ pi 2) (s2d (strcat (nth 0 k) "." k_phut "00"))))
			(setq canh (* 200 (- (atoi (nth 2 k)) (atoi (nth 3 k)))))
			(setq cdo (LM:roundto (/ (- cdo_ngam (atoi (nth 2 k))) 10.0) 0))	
			(setq x_k (+ xdau (* canh (cos goc))))
			(setq y_k (+ ydau (* canh (sin goc))))
			
			(MakePoint (list x_k y_k cdo) "point" 2)
			(K_text (list x_k y_k) 200 (itoa i) "L" "stt" nil 3 nil nil)
			(K_text (mapcar '+ (list x_k y_k) '(0 -250.0 0)) 200 (rtos cdo 2 0) "L" "cdo" nil 4 nil nil)
			(setq i (1+ i))
		)
		(MakePoint (list xdau ydau 3067) "point" 2)
		(K_text (list xdau ydau) 200 "Tram" "L" "tram" nil 1 nil nil)
	)
)
(setvar 'angdir dir)
(setvar 'cmdecho 1)
(princ)
)

Xin phép em viết lisp này! Không biết như vậy đã hoàn thiện chưa ạ! Mong các bác chỉ giáo!

(vl-load-com)
(defun C:DUAN (/ ELAST LOOP LTSOBJ  PT1 PT2 SSA)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar...
>>

Xin phép em viết lisp này! Không biết như vậy đã hoàn thiện chưa ạ! Mong các bác chỉ giáo!

(vl-load-com)
(defun C:DUAN (/ ELAST LOOP LTSOBJ  PT1 PT2 SSA)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar 'CMDECHO 0)
  (Prompt
    "\nQu\U+00E9t ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng \U+0111\U+1EC3 copy v\U+00E0 xoay:"
  )
  (setq ssa (ssget))
  (setq Loop T)
  (setq pt1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m chu\U+1EA9n: "))
  (while Loop
    (setq pt2 (getpoint pt1 "\nCh\U+1ECDn \U+0111i\U+1EC3m \U+0111\U+1EB7t: "))
    (cond
      (T
       (if pt2
	 (progn
	   (setq Elast (entlast))
	   (command "copy" ssa "" pt1 pt2 )
	   (setq LtsObj (GetNewEnts Elast))
	   (command "rotate" (CV:List-to-ss LtsObj) "" pt2 pause)
	 )
	 (setq Loop nil)
       )
      )
    )
  )
  (setvar 'OSMODE Olmode)
  (princ)
)
(defun CV:List-to-ss (lst / ss)
  (setq ss (ssadd))
  (foreach item	lst
    (or	(= (type item) 'Ename)
	(setq item (vlax-vla-object->ename item))
    )
    (setq ss (ssadd item ss))
  )
  ss
)

(defun GetNewEnts (ename / new)
  (while (setq ename (entnext ename))
    (if	(entget ename)
      (setq new (cons ename new))
    )
  )
  new
)
 ;|«Visual LISP© Format Options»
(200 2 60 2 nil "end of " 80 9 0 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

Có thể là như này ^^

(defun c:-()
  (vl-load-com)  
     (setq sbt (car (entsel "\nChon so bi tru:"))
           st (car (entsel "\nChon so tru:\n"))
           kq (- (atof (vl-string-subst "." "," (cdr (assoc 1 (entget sbt)))))
             (atof (vl-string-subst "." "," (cdr (assoc 1 (entget st)))))))      
     (princ kq)
  (setq obj (vlax-ename->vla-object (car (entsel "\nChon text ghi ket...
>>

Có thể là như này ^^

(defun c:-()
  (vl-load-com)  
     (setq sbt (car (entsel "\nChon so bi tru:"))
           st (car (entsel "\nChon so tru:\n"))
           kq (- (atof (vl-string-subst "." "," (cdr (assoc 1 (entget sbt)))))
             (atof (vl-string-subst "." "," (cdr (assoc 1 (entget st)))))))      
     (princ kq)
  (setq obj (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua:"))))
  (vla-put-TextString obj (vl-string-subst "," "." (rtos kq 2 2)))  
  (princ))