Vậy là độ chế dim rồi.

Bạn thử cái Lisp này Tue_NV viết xem sao :

(defun c:Rdim()
(prompt "\n Moi ban chon cac dim can lam tron :")
(setq ss (ssget '((0 ....
>>

Vậy là độ chế dim rồi.

Bạn thử cái Lisp này Tue_NV viết xem sao :

(defun c:Rdim()
(prompt "\n Moi ban chon cac dim can lam tron :")
(setq ss (ssget '((0 . "DIMENSION")))
i 0)
(while (< i (sslength ss))
(setq ent (entget(ssname ss i)))
(setq content (cdr(assoc 42 ent)))
(setq du (rem content 5))
(if (= du 0) (setq content content))
(if (and (> du 0) (< du 2.5)) (setq content (rtos (- content du) 2 0)))
(if (>= du 2.5) (setq content (rtos (+ content (- 5 du)) 2 0)))
(setq ent (entmod(subst(cons 1 content) (assoc 1 ent) ent)))
(setq i (1+ i))
)
(princ)
)

Cảm ơn bác Tue_NV nhé!!! Lish của bác quá hay, vậy là em sử lý được vụ này roài, hii :s_dead:

<<

@Duong Nhat Duy

2 giờ trước, Duong Nhat Duy đã nói:

>>

@Duong Nhat Duy

2 giờ trước, Duong Nhat Duy đã nói:

Mình đang rất gấp, mình xin phép được nhờ các ae trong forum viết hoặc lên ý tưởng hộ mình vấn đề sau:

Mình có các arc rời rạc, cần 1 lisp chuyển (hoặc tạo) arc đó thành 1 pline, trong đó có 2 đầu là 2 đoạn thẳng, ở giữa là arc, độ dài 2 đoạn thẳng cho mình chỉ định (ví dụ 1,2,3 gì đấy, lấy bằng hàm getPointatDist gì gì đó, để ra 1 cái điểm cách 2 mút chính xác 1 khoảng như đã chỉ định, bán kính của arc mới chính bằng arc cũ.

Phiền các bạn giúp đỡ mình nhé, mình xin cảm ơn !

chữa cháy nhé, không biết có đúng ý hay không. CHú ý dòng lệnh command, mình chạy trên acad2007 không bị áo lỗi

Vòng lập và tham số chiều dài Bạn viết thêm vào nhé

(defun c:alp (/ ANGE ANGS APE APS E1 E2 EN EP L PE PS SP SS);arc + line => polyline
  (setq	en   (car (entsel "\nChon arc: "))
	ep   (vlax-curve-getEndPoint en)
	sp   (vlax-curve-getStartPoint en)
	l    (vlax-curve-getDistAtPoint en ep)
	ps   (vlax-curve-getPointAtDist en 1e-8)
	pe   (vlax-curve-getPointAtDist en (- l 1e-8))
	aps  (angle ps sp)
	ape  (angle pe ep)
	angs (angle '(0 0)
		    (Vlax-curve-getfirstderiv
		      en
		      (vlax-curve-getParamAtPoint en sp)
		    ) ;_ end of Vlax-curve-getfirstderiv
	     ) ;_ end of angle
	ange (angle '(0 0)
		    (Vlax-curve-getfirstderiv
		      en
		      (vlax-curve-getParamAtPoint en ep)
		    ) ;_ end of Vlax-curve-getfirstderiv
	     ) ;_ end of angle
  ) ;_ end of setq
  (if (< 1. (abs (- ape ange)))
    (setq ange (+ ange pi))
    ange
  ) ;_ end of if
  (if (< 1. (abs (- aps angs)))
    (setq angs (+ angs pi))
    angs
  ) ;_ end of if
  (setq	e1 (entmakex (list '(0 . "LINE")
			   (cons 10 sp)
			   (cons 11 (polar sp angs 5))
		     ) ;_ end of list
	   ) ;_ end of entmakex
  ) ;_ end of setq
  (setq	e2 (entmakex (list '(0 . "LINE")
			   (cons 10 ep)
			   (cons 11 (polar ep ange 5))
		     ) ;_ end of list
	   ) ;_ end of entmakex
  ) ;_ end of setq
  (setq ss (ssadd))
  (ssadd en ss)
  (ssadd e1 ss)
  (ssadd e2 ss)
  (command ".pedit" "m" ss "" "y" "j" 0 "")
  (princ)
)

Theo y/c của Bạn, số chẵn màu 5, số lẽ màu 3

(defun c:cle ( / num ss _dxf)
  (defun _dxf (code e) (cdr (assoc code (entget e))))
  (setq ss (ssget '((0 . "*TEXT"))))
  (foreach n (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if(and
	 (setq num (distof (_dxf 1 n)))
	 (= (rem num 1) 0);chon so nguyen
	 )
      (if(= (rem num 2) 0); chon so chan
	(vla-put-color(vlax-ename->vla-object...
>>

Theo y/c của Bạn, số chẵn màu 5, số lẽ màu 3

(defun c:cle ( / num ss _dxf)
  (defun _dxf (code e) (cdr (assoc code (entget e))))
  (setq ss (ssget '((0 . "*TEXT"))))
  (foreach n (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if(and
	 (setq num (distof (_dxf 1 n)))
	 (= (rem num 1) 0);chon so nguyen
	 )
      (if(= (rem num 2) 0); chon so chan
	(vla-put-color(vlax-ename->vla-object n) 5); so chan mau 5
	(vla-put-color(vlax-ename->vla-object n) 3); so le mau 3
	)
      )
    )
  (princ)
  )

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các...

>>

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các đối tượng mà có cùng layer như đối tượng được chọn, sau đó tự động chuyển thành 1 layer mới mà mình định sẵn và đã có sẵn ở trong bản vẽ. Mình có mày mò, xem các bài viết trên diễn đàn nhưng không tìm thấy. Mình cũng biết lệnh LAYMRG, nhưng vì 1 vài lý do nên các bạn có thể giúp mình làm lisp như mình trình bày ở trên không ạ.

Mình có xem qua các bài viết, xong viết 1 cái như thế này nhưng không chạy được ạ :)

(defun c:qqq1 (/ targent)

  (setq TargEnt (car (entsel "\nSelect object on layer to select: ")))

  (Setq chuyen (sssetfirst nil (ssget "_X" (list (assoc 8 (entget TargEnt)))))

  (command "chprop" chuyen "" "la" "Hidden"  "")

  (princ)

Mong các bạn giúp đỡ :)

(defun c:qqq1 (/ targent chuyen)

(setq TargEnt (car (entsel "\nSelect object on layer to select: ")))

(Setq chuyen (ssget "_X" (list (assoc 8 (entget TargEnt)))))

(command "chprop" chuyen "" "la" "Hidden" "")

(princ)

)

<<

Download lisp

Filename: 419470_qqq1.lsp

Cái này áp dụng cho cả Dim và *TEXT

(vl-load-com)(defun c:tt (/ repentmod els ss str)

(defun repentmod...

>>

Cái này áp dụng cho cả Dim và *TEXT

(vl-load-com)(defun c:tt (/ repentmod els ss str)

(defun repentmod (cha text_str lst flag / pos dim_dec)

(if (and (wcmatch (cdr (assoc 0 lst)) "*DIMENSION") (eq text_str (chr 0)))

(setq dim_dec (cdr (assoc 271 (tblsearch "DIMSTYLE" (cdr (assoc 3 lst)))))

text_str (rtos (cdr (assoc 42 lst)) 2 dim_dec)))

(if (vl-string-search cha (strcase text_str))

(while (setq pos (vl-string-search cha (strcase text_str)))

(setq text_str (strcat (substr text_str 1 pos) (substr text_str (+ 2 pos)))))

(cond ((eq flag 1) (setq text_str (strcat cha text_str)))

((eq flag 0) (setq text_str (strcat text_str cha)))))

(entmod (subst (cons 1 text_str) (assoc 1 lst) lst)))

(and (setq ss (ssget '((0 . "*TEXT,*DIMENSION"))))

(mapcar '(lambda (x) (repentmod (chr 40) (cdr (assoc 1 (entget x))) (entget x) 1))

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

(mapcar '(lambda (x) (repentmod (chr 41) (cdr (assoc 1 (entget x))) (entget x) 0))

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

(princ))

Cái này mình xài đc nè.cảm ơn bạn quocmanh04tt nhiều nha!

<<

Download lisp

Filename: 405391_tt.lsp

Cái này áp dụng cho cả Dim và *TEXT

(vl-load-com)(defun c:tt (/ repentmod els ss str)

(defun repentmod...

>>

Cái này áp dụng cho cả Dim và *TEXT

(vl-load-com)(defun c:tt (/ repentmod els ss str)

(defun repentmod (cha text_str lst flag / pos dim_dec)

(if (and (wcmatch (cdr (assoc 0 lst)) "*DIMENSION") (eq text_str (chr 0)))

(setq dim_dec (cdr (assoc 271 (tblsearch "DIMSTYLE" (cdr (assoc 3 lst)))))

text_str (rtos (cdr (assoc 42 lst)) 2 dim_dec)))

(if (vl-string-search cha (strcase text_str))

(while (setq pos (vl-string-search cha (strcase text_str)))

(setq text_str (strcat (substr text_str 1 pos) (substr text_str (+ 2 pos)))))

(cond ((eq flag 1) (setq text_str (strcat cha text_str)))

((eq flag 0) (setq text_str (strcat text_str cha)))))

(entmod (subst (cons 1 text_str) (assoc 1 lst) lst)))

(and (setq ss (ssget '((0 . "*TEXT,*DIMENSION"))))

(mapcar '(lambda (x) (repentmod (chr 40) (cdr (assoc 1 (entget x))) (entget x) 1))

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

(mapcar '(lambda (x) (repentmod (chr 41) (cdr (assoc 1 (entget x))) (entget x) 0))

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

(princ))

Thanks bạn quocmanh04tt nhiều! Lsp này áp dụng cho cv của mình quá ok. 

<<

Download lisp

Filename: 405343_tt.lsp

4 phút trước, trinhcaro đã nói:

Em dùng nó báo lỗi này bác...

>>

4 phút trước, trinhcaro đã nói:

Em dùng nó báo lỗi này bác ạ.

CT
; error: no function definition: L?IST

(vl-load-com)
(defun c:ct (/ ss a i ent txt new)
  (setq ss (ssget (list (cons 0 "TEXT") (cons 1 "BOP=V-*")))
	a (getreal "\nNhap so cong them: ")
	i 0)
  (while (setq ent (ssname ss i))
  	(setq i (1+ i))
    (setq txt (vla-get-textstring (vlax-ename->vla-object ent)))
    (setq new (rtos (+ a (atof (substr txt 7))) 2 2))
    (vla-put-textstring (vlax-ename->vla-object ent) (strcat "BOP=V-" new))
    ))

Chắc do bạn chưa cài Expresstool, đã sửa lại 

<<

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các đối tượng mà có cùng layer như đối tượng được chọn, sau đó tự động chuyển thành 1 layer mới mà mình định sẵn và đã có sẵn ở trong bản vẽ. Mình có mày mò, xem các bài viết trên diễn đàn nhưng không tìm thấy. Mình cũng biết lệnh LAYMRG, nhưng vì 1 vài lý do nên các bạn...

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các đối tượng mà có cùng layer như đối tượng được chọn, sau đó tự động chuyển thành 1 layer mới mà mình định sẵn và đã có sẵn ở trong bản vẽ. Mình có mày mò, xem các bài viết trên diễn đàn nhưng không tìm thấy. Mình cũng biết lệnh LAYMRG, nhưng vì 1 vài lý do nên các bạn có thể giúp mình làm lisp như mình trình bày ở trên không ạ.

Mình có xem qua các bài viết, xong viết 1 cái như thế này nhưng không chạy được ạ :)

(defun c:qqq1 (/ targent)
  (setq TargEnt (car (entsel "\nSelect object on layer to select: ")))
  (Setq chuyen (sssetfirst nil (ssget "_X" (list (assoc 8 (entget TargEnt)))))
  (command "chprop" chuyen "" "la" "Hidden"  "")
  (princ)

Mong các bạn giúp đỡ :)

Bạn phải tạo trước 4 layer và khai báo vào trong lisp, mỗi lần chọn các đối tượng lisp sẽ thay đổi tối đa cho 4 đối tượng theo thứ tự từ trên xuống

(defun c:tal (/ ss lslay)		;tach layer cho cac text
  (setq lslay '("1" "2" "3" "4"))	;ten cac layer da co
  (while (setq ss (ssget '((0 . "TEXT"))))
    (setq ss (mapcar 'vlax-ename->vla-object
		    ...
>>

Bạn phải tạo trước 4 layer và khai báo vào trong lisp, mỗi lần chọn các đối tượng lisp sẽ thay đổi tối đa cho 4 đối tượng theo thứ tự từ trên xuống

(defun c:tal (/ ss lslay)		;tach layer cho cac text
  (setq lslay '("1" "2" "3" "4"))	;ten cac layer da co
  (while (setq ss (ssget '((0 . "TEXT"))))
    (setq ss (mapcar 'vlax-ename->vla-object
		     (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	     ) ;_ end of mapcar
    ) ;_ end of setq
    (setq ss (vl-sort ss
		      '(lambda (e1 e2)
			 (> (cadr (vlax-get e1 'InsertionPoint))
			    (cadr (vlax-get e2 'InsertionPoint))
			 ) ;_ end of >
		       ) ;_ end of lambda
	     ) ;_ end of vl-sort
    ) ;_ end of setq
    (mapcar '(lambda (x y) (vla-put-layer x y)) ss lslay)
  ) ;_ end of while
  (princ)
) ;_ end of defun

Hề hề, cho Vàng bạn luôn. :D

Anh Duy và bạn kẽtu hãy thử Lisp này

(defun c:1(/ ov vl)
(setvar "hpname" "ansi31") 
 (setq vl '("clayer" "cmdecho"); Sys Var...
>>

Hề hề, cho Vàng bạn luôn. :D

Anh Duy và bạn kẽtu hãy thử Lisp này

(defun c:1(/ ov vl)
(setvar "hpname" "ansi31") 
 (setq vl '("clayer" "cmdecho"); Sys Var list
ov (mapcar 'getvar vl)); Get Old values
 (setvar "cmdecho" 1) 
 (if (tblsearch "layer" "KT-Hatch")
(setvar "CLAYER" "KT-Hatch")
(command "-layer" "M" "KT-Hatch" "" ) )
 (initdia)
 (command "hatch")
 (while (	(command pause)
 ) 
 (vl-cmdf "change" "L" "" "P" "LA" "KT-Hatch" "")
 (mapcar 'setvar vl ov); reset Sys Vars
 (princ)
 )

Là thành viên mới,e cũng biết cách tốt nhất là ấn TKS,nhưng phải phản hồi mới thấy được hết sự vui mừng.Tks bác,code chạy ngon lắm.Thấy hpname nhận đc cả custom pat cũng vui quá ^^

Em gửi thêm 1 nguyện vọng nữa,mong các bác giúp đỡ:

- Thực hiện lệnh bắn line (hoặc pline) vào giao điểm của 2 đường line gần nhất.Ở đầu vào User kích chọn vào đường line cần bắn.

- Thực hiện lệnh bắn line (hoặc pline) vào 1 điểm gấp khúc gần nhất của các đường pline xung quanh.Ở đầu vào User kích chọn vào đường line cần bắn và có lựa chọn pick hay không cần kick vào pline.(Giống lệnh ex,hay trim,có thể chọn hoặc không chọn đường biên ý ạ.vì có thể có nhiều pl xung quanh mũi đường l,pl gốc,người dùng không phải băn khoăn xem đường nào gần nhất).

Mong các bác giúp đỡ e vấn đề 1,còn vấn đề 2 thì với bản thân e chưa cần thiết lắm,e chỉ nghĩ nên mở rộng vấn đề như thế thôi.hì ^^

<<

của Bạn đây

(defun c:fao (/ bn ld as lt 2v 3d e p p1 p2 _att a en)
  (vl-load-com)
  (setq	bn "SDDMOI"
	ld "KHIEU"
	as "DTICH"
	lt "TENBLOCK"
  )					;Change by user
  (or *st* (setq *st* 1))
  (setq	2v vlax-ename->vla-object
	3d vlax-3D-point
  ) ;_ end of setq
  (while (not (setq s (ssget "_+.:E:S" (list (cons 2 bn)))))
    (princ "\nMiss!")
  ) ;_ end of while
  (setq	e    (2v (ssname s 0))
	*st*...
>>

của Bạn đây

(defun c:fao (/ bn ld as lt 2v 3d e p p1 p2 _att a en)
  (vl-load-com)
  (setq	bn "SDDMOI"
	ld "KHIEU"
	as "DTICH"
	lt "TENBLOCK"
  )					;Change by user
  (or *st* (setq *st* 1))
  (setq	2v vlax-ename->vla-object
	3d vlax-3D-point
  ) ;_ end of setq
  (while (not (setq s (ssget "_+.:E:S" (list (cons 2 bn)))))
    (princ "\nMiss!")
  ) ;_ end of while
  (setq	e    (2v (ssname s 0))
	*st* (cond ((getint (strcat "Start Number <" (itoa *st*) ">:")))
		   (*st*)
	     ) ;_ end of cond
	p    (getpoint "\nBase point :")
	p1   (3d p)
	_att (lambda (b tag v / r)
	       (foreach	at (vlax-invoke b 'GetAttributes)
		 (if (eq tag (vla-get-TagString at))
		   (setq r
			  (if v
			    (vla-put-textstring at v)
			    (vla-get-textstring at)
			  ) ;_ end of if
		   ) ;_ end of setq
		 ) ;_ end of if
	       ) ;_ end of foreach
	       r
	     ) ;_ end of lambda
  ) ;_ end of setq
  (while (setq p2 (acet-ss-drag-move s p "\nTo :"))
    (cond ((setq en (bpoly p2))
	   (setq a (vla-get-area (2v en)))
	   (entdel en)
	   (vla-move (setq n (vla-copy e)) p1 (3d p2))
	   (_att n
		 ld
		 (strcat
		   (_att n lt nil)
		   (if (< *st* 10)
		     "-0"
		     "-"
		   ) ;_ end of if
		   (itoa *st*)
		 ) ;_ end of strcat
	   ) ;_ end of _att
	   (_att n as (vl-string-translate "." "," (rtos (* a 0.0001) 2 4))); thay doi dong nay
	   (setq *st* (1+ *st*))
	  )
    ) ;_ end of cond
  ) ;_ end of while
) ;_ end of defun

Mọi góp ý đều đuợc hoan nghênh. Cám ơn thanhduan2407 nhiều.

Do mới tập tành viết .NET, nên chỉ đúng cho truờng hợp đuờng bao là đa giác...

>>

Mọi góp ý đều đuợc hoan nghênh. Cám ơn thanhduan2407 nhiều.

Do mới tập tành viết .NET, nên chỉ đúng cho truờng hợp đuờng bao là đa giác lồi.

Chào Tue_NV!

Lisp's level của Tue_NV cao quá trời.

Xin chúc mừng! :D

 

LISP AIC chạy rất tốt, chỉ xin bổ sung phần thông báo trực quan :

Trong truờng hợp 1 Lisp chạy quá lâu (VD: lớn hơn 10 giây) thông thuờng CAD cũng không có thông báo là Lisp đang chạy, nguời sử dụng đôi khi nghĩ rằng Cad bị treo (Not responding) và họ ra quyết định ... bấm phím ESC (tèn ten : công toi)

Để tạo 1 thông báo trực quan, chúng ta có thể sử dụng hàm acet-ui-progress của Express Tool

VD :

 

Cách sử dụng : (minh họa với Lisp AIC của Tue_NV)

1. kiểm tra CAD có cài đặt Express Tool.

(setq Express (and (vl-position "acetutil.arx" (arx))

(not

(vl-catch-all-error-p

(vl-catch-all-apply

(function (lambda nil (acet-sys-shift-down))))))))

 

2. Khởi động thanh trạng thái truớc khi gọi hàm sử lý xóa đối tuợng:

(if Express (setq ProgBar (acet-ui-progress "Vui long doi ! Dang xoa doi tuong ..." (sslength ssa))))

 

3. Trong vòng lặp xóa đối tuợng, cập nhật thanh trạng thái :

(foreach x ssa

(setq line (vla-addline ms (vlax-3d-point minpp)

(vla-get-insertionpoint x) ) )

; ...

;update thanh trang thai

(if Express (acet-ui-progress -1)) )

 

4. Giải phóng thanh trạng thái khi kết thúc vòng lặp :

(if Express (setq ProgBar (acet-ui-progress)))

Update LISP : Copy Block trong đuờng bao Pline kín.

(defun c:CopyBlk (/ baseCur basePt blk blkObj cur curObj dis i maxpt minpt ov pt vl doc spc start time)
 ;| By : Gia Bach, gia_bach @  www.CadViet.com             |;  
 (vl-load-com)

 (defun *error* (msg)
   (and Express ProgBar (acet-ui-progress))
   (and ov (mapcar 'setvar vl ov))    
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (setq Express (and (vl-position "acetutil.arx" (arx))
	     (not
	       (vl-catch-all-error-p
		 (vl-catch-all-apply
		   (function (lambda nil (acet-sys-shift-down))))))))

 (setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
       ov (mapcar 'getvar vl)) ; Get Old values  
 (mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE

 (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
       spc (if (zerop (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))

 (setq blk (car (entsel "\nChon Block :"))
blkObj (vlax-ename->vla-object blk)
basePt (cdr (assoc 10 (entget blk))))

 (or *dis* (setq *dis* 10))
 (initget 6)
 (setq dis (getdist (strcat "\nKhoang cach <" (rtos *dis*) "> :")))
 (if dis (setq *dis* dis) (setq dis *dis*) )

 (setq cur (car (entsel "\nChon Pline :"))
curObj (vlax-ename->vla-object cur))
 (vla-GetBoundingBox (vlax-ename->vla-object cur) 'minpt 'maxpt)
 (setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
minpt (polar minpt (/ pi 4) (/ dis 4))
baseCur (polar minpt (/ pi 4) (/ dis -4))
pt minpt
i 1)

 (setq start (getvar "MILLISECS"))
 (if Express (setq ProgBar (acet-ui-progress "Vui long doi ! Dang tinh toan ..." (fix(/ (- (cadr maxpt) (cadr minpt))dis)))))

 (while (< (cadr pt) (cadr maxpt))
   (while (< (car pt) (car maxpt))
     (if (insidep pt curObj baseCur)
(vla-move (vla-copy blkObj) (vlax-3D-point basePt) (vlax-3D-point pt)))
     (setq pt (polar pt 0 dis)))
   (setq pt (polar minpt  (/ pi 2.0) (* i (/ dis 2)))
  i (1+ i) )
   (if (= (rem i 2)0)
     (setq pt (polar pt 0 (/ dis 2))))
   (if Express (acet-ui-progress -1)) )
 (if Express (setq ProgBar (acet-ui-progress)))

 (setq time (/ (- (getvar "MILLISECS") start) 1000.0))
 (princ (strcat "Thoi gian thuc hien (giay) : " (rtos time)))
 (mapcar 'setvar vl ov)
 (princ))

(defun insidep (pt Obj basePt / flag int lin ClosestPoint)
 (setq ClosestPoint (vlax-curve-getClosestPointTo obj pt))
 (if (equal ClosestPoint pt 1e-6)
   (setq flag nil)
   (progn
     (setq flag (and (setq int (vlax-invoke
			  (setq lin(vla-addLine spc (vlax-3D-point pt) (vlax-3D-point basePt)))
			  'IntersectWith Obj 0))
	      (= (rem (length int) 2) 1)) )
     (vla-delete lin)) )
 flag)

Chào bác giabach, lisp của bác thật tuyệt, nhưng vẫn có 1 lỗi nhỏ là nó không xóa sạch những block được tạo ra thêm ở ngoài đướng bao khi chạy lisp, ngoài ra nó còn xóa 1 vài block bên trong đường bao. Bác cứ thử lisp khi đường bao là 1 đa giác lõm và khoảng cách các block được tạo là tương đối nhỏ thì sẽ thấy. Có lẽ lỗi do cái hàm insidep thì phải. Lâu quá mới vào diễn đàn, lúc rày thiep bận việc quá. Chúc bác khỏe!

<<

Quên béng mất lời hẹn ^^

 

(defun c:test ( / lst ss blkName change)
(defun change ( block layer )
 (vl-load-com)
 (if
  ...
>>

Quên béng mất lời hẹn ^^

 

(defun c:test ( / lst ss blkName change)
(defun change ( block layer )
 (vl-load-com)
 (if
   (not
     (vl-catch-all-error-p
       (setq def
         (vl-catch-all-apply 'vla-item
           (list
             (vla-get-blocks
               (vla-get-ActiveDocument
                 (vlax-get-acad-object)
               )
             )
             block
           )
         )
       )
     )
   )
   (vlax-for obj def
(vl-catch-all-apply 'vla-put-color (list obj
(if  (= (setq col (vla-get-color obj)) 256)
(cdr (assoc 62 (tblsearch "LAYER" (vla-get-layer obj))))
col
)
))
(vl-catch-all-apply 'vla-put-layer (list obj layer))
   )
 )
)
 (cond ((setq ss (ssget (list (cons 0 "INSERT"))))
(foreach blk (acet-ss-to-list ss)
(vl-catch-all-apply 'vla-put-layer (list (vlax-ename->vla-object blk) "Block"))
(if (not (vl-position (setq blkName (cdr (assoc 2 (entget blk)))) lst))    
(progn
(change blkName "Block")
(setq lst (cons blkName lst))
)
)
)
)
 )
 (command "_.regenall")
 (princ)
)

Anh Ket ơi em chạy thử đoạn lisp của anh nhưng vẫn chưa được anh ạ. Cad không báo lỗi gì nhưng vẫn chưa chuyển được layer của Block cũng như các đối tượng trong block, Anh xem lại giúp em với nhé!

<<

Bạn đã cài Express Tool chưa? Nếu chưa cài thì dùng thử cái này xem có được không. Trên máy mình chạy ngon.

>>

Bạn đã cài Express Tool chưa? Nếu chưa cài thì dùng thử cái này xem có được không. Trên máy mình chạy ngon.

;====CHUYEN TEXT TU LAYER DEFPOINTS TRONG BLOCK ATTRIBUTE VE LAYER "0"====
;=======================KANGKUNG 05/04/2013===============================
;========================UPDATED 07/04/2013===============================
(defun c:KK()
  (vl-load-com)
  (setq taphop(ssget "_X" '((0 . "INSERT"))) i 0)
  (while (< i (sslength taphop))
    (SETQ EN2(ENTNEXT(ssname taphop i)))
    (SETQ ENLIST2(ENTGET EN2))
    (while (/= (cdr(assoc 0 enlist2)) "SEQEND")
      (setq en2(entnext en2))
      (setq enlist2(entget en2))
      (if (= "DEFPOINTS" (cdr(assoc 8 enlist2)))
	(entmod (subst (cons 8 "0") (assoc 8 enlist2) enlist2))
	)
      )
    (setq i(1+ i))
    )
  (command "REGEN")
  (alert "Well Done")
  )
(princ "\n                Written By KangKung - 05/04/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Không hiểu sao trên máy em không chạy được lisp trên, mặc dù e có cài express tool rồi; thử trên cad mới cũ gì cung không được. Dù sao cũng cảm ơn anh KangKung.

Chắc giống ntn : bạn chọn đối tượng, chọn basepoint, sau đó kick 4 điểm theo thứ tự 2 điểm thuộc đường 1, 2 điểm thuộc đường 2 nhé

;free lisp...
>>

Chắc giống ntn : bạn chọn đối tượng, chọn basepoint, sau đó kick 4 điểm theo thứ tự 2 điểm thuộc đường 1, 2 điểm thuộc đường 2 nhé

;free lisp from cadviet.com @ ketxu
(defun c:m2g() 
(command ".move" (ssget) "" pause 
(inters
(getpoint "\n Diem thu 1 : ")
(getpoint "\n Diem thu 2 :")
(getpoint "\n Diem thu 3 :")
(getpoint "\n Diem thu 4 :")
nil
)
)
)

 

Quá hay, mình đang bặp bẹ viết lisp và dùng mấy cái tài liệu nhiều quá nản, bác có tài liệu cơ bản và đơn giản không shared mình với

<<

(defun c:stt (/ ans ans1 ins lst blkName tagName ent) ;Block Order
  ;;  By : Gia_Bach, www.CadViet.com      ;;
  (vl-load-com)
  (while (not (and
                (setq ent (car (nentsel "\n Chon thuoc tinh can danh so: ")))
                (if ent
                  (eq (cdr (assoc 0 (entget ent))) "ATTRIB")
                )
              )
         )
    (princ "\n Ban chon nham roi! ")
  )
  (setq blkName (cdr...
>>

(defun c:stt (/ ans ans1 ins lst blkName tagName ent) ;Block Order
  ;;  By : Gia_Bach, www.CadViet.com      ;;
  (vl-load-com)
  (while (not (and
                (setq ent (car (nentsel "\n Chon thuoc tinh can danh so: ")))
                (if ent
                  (eq (cdr (assoc 0 (entget ent))) "ATTRIB")
                )
              )
         )
    (princ "\n Ban chon nham roi! ")
  )
  (setq blkName (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent))))))
        tagName (cdr (assoc 2 (entget ent)))
  )

  (initget 1 "Yes No")
  (setq x (getkword "\nBan co muon nhap Tien to va Hau to ? (Yes or No) "))
  (if (= x "Yes")
    (progn
      (or prefix (setq prefix "KC-"))
      (setq ans (getstring t (strcat "\n Nhap tien to <<" prefix ">> :")))
      (setq ans1 (getstring t "\n Nhap hau to: "))
      (if (/= ans "")
        (setq prefix ans)
      )
    )
    (setq prefix "")
  )

  (or stt (setq stt 1))
  (initget 6)
  (setq ans (getint (strcat "\n Nhap so bat dau <<" (itoa stt) ">> :")))
  (if ans
    (setq stt ans)
  )
;;;  (if (> stt 9)
;;;    (setq str (strcat prefix (itoa stt) ans1))
;;;    (setq str (strcat prefix  "0" (itoa stt) ans1)) )    

  (princ "\nChon Khung ten can danh so thu tu :")
  (if (ssget (list (cons 0 "INSERT") (cons 66 1) (cons 2 blkName)))
    (progn
      (vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
        (setq ins (vlax-safearray->list (variant-value (vla-get-InsertionPoint e)))
              lst (cons (list e ins) lst)
        )
      )
      (setq lst (vl-sort lst
                         '(lambda (x y)
                            (or (> (cadr (cadr x)) (cadr (cadr y)))
                                (and (< (car (cadr x)) (car (cadr y)))
                                     (= (cadr (cadr x)) (cadr (cadr y)))
                                )
                            )
                          )
                )
      )
      (foreach e (append (mapcar 'car lst))
        (if (> stt 9)
          (setq str (strcat prefix (itoa stt) ans1))
          (setq str (strcat prefix "0" (itoa stt) ans1))
        )
        (foreach Att (vlax-invoke e 'GetAttributes)
          (if (= (vla-get-TagString att) tagName)
            (vla-put-TextString att str)
          )
        )
        (setq stt (+ 1 stt))
      )
    )
  )
  (princ)
)

19 giờ trước, loranypt đã nói:

Chào các bro trong...

>>

19 giờ trước, loranypt đã nói:

Chào các bro trong diễn đàn,

 

Hiện tại mình đang tính thép sàn và công việc đang dung 3 lisp theo qui trình như sau

 

1. Dùng lisp "sl" để rãi thép sàn xuất ra text

2. Copy cái text đó ra kế bên

3.Dùng lisp "tt" để add chiều dài thanh thép vô text vừa copy

4.Dùng lisp "at2t" để kết hợp text bước 1 và bước 3 lại với nhau

5. Dùng lisp thống kê text và xuất số lieu ra excel để xử lý.

 

Nay mình nhờ bác nào rành lisp có thể kết hợp 4 bước đầu tiên lại để tiết kiệm thời gian được ko ạ.

 

qui trình mong muốn :

1. bấm lệnh

2.chọn điểm đầu và cuối khoản rãi

3.nhập khoảng cách giữa các thanh thép

4.nhập đường kính thép

5.chọn thanh thép (đường Pline)

6. bấm và text có sẵn để thay bằng text mới có dạng : "số thanh thép-Dthép -Lthep"

 

mình đính kèm 3 lisp "sl", "tt", "at2t" để tiện cho các bác kết hợp

 

 

Mong các bác giúp với vì tiến 18 sàn mà cuối tuầần Giao bài rồ

at2t.lsp

sl.lsp

tt.lsp

;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/163324-lisp-r%C3%A3i-th%C3%A9p-s%C3%A0n/
(defun c:SL (/ a1 c)
  (setq luu (getvar "osmode"))
  (setq lay (getvar "clayer"))
                    ;(command "layer" "s" "Defpoints" "")
                    ;(command "osnap" "Perp,Near")
  (setq p1 (getpoint "Chon diem xuat phat\n"))
  (setq p2 (getpoint p1 "Chon diem ket thuc\n"))
;;;(setq a1 (getdist "\nCh\U+1ECDn kho\U+1EA3ng r\U+1EA3i th\U+00E9p: "))
  (command "_Pline" p1 p2 "")
  (setq a1 (Distance p1 p2))
  (or (and a (or (= (type a) 'int) (= (type a) 'real)))
      (setq a 200)
  )
  (setq
    a (cond ((getdist
           (strcat "\nKho\U+1EA3ng c\U+00E1ch thanh th\U+00E9p <"
               (rtos a 2 2)
               ">:"
           )
         )
        )
        (a)
      )
  )
  (setq Caochu 300)
  (or (and hbv (or (= (type hbv) 'int) (= (type hbv) 'real)))
      (setq hbv 10)
  )
  (setq    hbv
     (cond
       ((getreal (strcat "\nduong kinh thep <" (rtos hbv 2 2) ">: ")
        )
       )
       (hbv)
     )
  )
  (setq c (1+ (/ a1 a)))
  (setq p (getpoint "\n Chon diem nhap ket qua" ))
  (entmake
             (list
               (cons 0 "TEXT")
               (cons 10 (list (car p) (cadr p)))
               (cons 40 Caochu)
               (cons
                 1
                 (strcat (rtos c 2 0) "D" (rtos hbv 2 0))
               )
             )
               )
;;;     (setq ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
;;;   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
;;;                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (strcat (rtos c 2 0) "D" (rtos hbv 2 0)) (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))
;;;           )
;;;)
;;;(vla-put-TextString txtObj (strcat (rtos c 2 0) "D" (rtos hbv 2 0)))
;;;(vla-put-Height txtObj #h)
;;;  (while (setq ent
;;;        (nentsel
;;;          "\nCh\U+1ECDn ghi gi\U+00E1 tr\U+1ECB (Text ho\U+0103c ATT):"
;;;        )
;;;     )
;;;    (and (wcmatch (cdr (assoc 0 (entget (car ent)))) "ATTRIB,*TEXT")
;;;     (vla-put-textstring
;;;       (vlax-ename->vla-object (car ent))
;;;       (strcat (rtos c 2 0) "D" (rtos hbv 2 0))
;;;     )
;;;    )
;;;  )
  (AC:TT)
  (Ac:at2t)
  (SETVAR "clayer" lay)
  (setvar "osmode" luu)
  (princ)
)
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/60478-nh%E1%BB%9D-ch%E1%BB%89nh-s%E1%BB%ADa%C4%91o-chi%E1%BB%81u-d%C3%A0i-v%C3%A0-ghi-ra-text/
(defun AC:TT( / ss L e #h)
(vl-load-com)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(or ans (setq ans 2))
  (Alert (strcat "Chon PLine thep\n"))
(setq
   #h 300
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))
   )))
   )
   ans 2;(cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))
           )
)
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ)
)
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/13074-lisp-gh%C3%A9p-text-c%E1%BA%A7n-gi%C3%BAp-%C4%91%E1%BB%A1/?page=2
(defun Ac:at2t (/ center color data edata ent i sel ss str);All Text to Text
 (defun centerSS (ss / lst_max lst_min maxpt minpt ll ur)
   (vl-load-com)
   (foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (vla-GetBoundingBox ent 'minpt 'maxpt)
     (setq lst_min (cons (vlax-safearray->list minpt) lst_min)
    lst_max (cons (vlax-safearray->list maxpt) lst_max)  )   )
   (setq ll (list (car (vl-sort (mapcar 'car lst_min) '<))
       (car (vl-sort (mapcar 'cadr lst_min) '<))  )
  ur (list (last (vl-sort (mapcar 'car lst_max) '<))
       (last (vl-sort (mapcar 'cadr lst_max) '<)) ) )
   (mapcar '/ (mapcar '+ ll ur) '(2.0 2.0 2.0))    )  

 (defun Change_Str (data pt str color)
   (entmake (list (cons 0 "TEXT") (assoc 8 data) (cons 10 pt)
       (cons 11 pt) (assoc 7 data) (assoc 40 data)
       (cons 71 0) (cons 72 1) (cons 73 2)
       (cons 1 str) (cons 62 color)
       (if (assoc 6 data)  (assoc 6 data)  '(6 . "BYLAYER") )
       (if (assoc 39 data) (assoc 39 data) '(39 . 0) )
       (if (assoc 370 data) (assoc 370 data) '(370 . -1) ) ))  )

 (defun dxf (tag obj) (cdr (assoc tag obj)))
;main
 (or *color* (setq *color* 6 ))
 (setq color (getint (strcat "\nNhap so mau cua Text sau khi hoan thanh <" (itoa *color*) "> :")) )
 (if color (setq *color* color) (setq color *color*))
 (setq ss (ssadd))
  (Alert (strcat "Chon Text chieu dai thep truoc\n"))
 (while    (setq sel (entsel "\nChon cac Text can noi voi nhau: "))
   (setq ent (car sel))
   (if (= (cdr (assoc 0 (entget ent))) "TEXT")
     (ssadd ent ss)
   )
 )  
 (if (> (sslength ss) 0)
   (progn
     (setq i -1
    str ""
    center (centerSS ss)        
    data (entget (ssname ss 0))        )
     (while (setq ent (ssname ss (setq i (1+ i))))
       (setq edata (entget ent)
         str   (strcat (dxf 1 edata)" " str  )
       )
       (entdel ent)
     )
     (Change_Str data center (substr str 1) color)     )
   (princ "\nKhong chon duoc Text !"))
 (princ))

@loranypt Mạo muội sửa thế này ko biết có đúng ý bạn ko? lệnh duy nhất SL

<<

 

Lisp vẽ trọng tâm của hình rỗng (hình khoét lỗ).

 

; Doan Van Ha - CadViet.com - ngay...
>>

 

Lisp vẽ trọng tâm của hình rỗng (hình khoét lỗ).

 

; Doan Van Ha - CadViet.com - ngay 29/11/2014
; Chuc nang: lay trong tam cua 1 hinh rong (hinh rong bao gom 1 duong bien ngoai va cac duong ben trong, duoc tao boi cac "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc").
; Ve 2 duong truc X va Y.
(defun C:HA(/ GetNewEnts ss ent lst emax smax ll ur ssum xtt ytt)
 (vl-load-com) (command "undo" "be")
 (defun GetNewEnts (ent / obj tt new)
  (while (setq ent (entnext ent))
   (setq obj (vlax-ename->vla-object ent) tt (vlax-get obj 'Centroid) new (cons (list obj (vlax-get obj 'Area) (car tt) (cadr tt)) new)))
  new)
 (princ "\nChon nhom doi tuong tao thanh hinh can lay trong tam: ")
 (setq ss (ssget '((0 . "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc"))))
 (setq ent (entlast))
 (command "region" ss "")
 (setq lst (vl-sort (GetNewEnts ent) '(lambda(e1 e2) (> (cadr e1) (cadr e2)))))
 (setq emax (caar lst) smax (cadar lst)) 
 (vla-getboundingbox emax 'll 'ur)
 (setq ll (vlax-safearray->list ll) ur (vlax-safearray->list ur))
 (setq ssum (apply '+ (mapcar '(lambda(x) (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x)))) lst)))
 (setq xtt (/ (apply '+ (mapcar '(lambda(x) (* (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x))) (caddr x))) lst)) ssum))
 (setq ytt (/ (apply '+ (mapcar '(lambda(x) (* (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x))) (cadddr x))) lst)) ssum))
 (command "u")
 (entmake (list '(0 . "Line") (cons 8 "HA_Truc") (cons 62 1) (cons 10 (list (car ll) ytt)) (cons 11 (list (car ur) ytt))))
 (entmake (list '(0 . "Line") (cons 8 "HA_Truc") (cons 62 1) (cons 10 (list xtt (cadr ll))) (cons 11 (list xtt (cadr ur)))))
 (command "undo" "e") (princ))
 

đúng như ý của chị hoan nhưng mỗi lần quét window chỉ chọn được 1 đối tượng

<<

18 giờ trước, loranypt đã nói:

minh load được lệnh rồi , nhưng...

>>

18 giờ trước, loranypt đã nói:

minh load được lệnh rồi , nhưng nó chỉ dừng tới chỗ rải thép , còn lấy thông tin chiều dài thanh thép thì lại error

;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/175622-y%C3%AAu-c%E1%BA%A7u-k%E1%BA%BFt-h%E1%BB%A3p-lisp/
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/163324-lisp-r%C3%A3i-th%C3%A9p-s%C3%A0n/
(defun c:sl (/ a1 c)
  (setq luu (getvar "osmode"))
  (setq lay (getvar "clayer"))
  (setq p1 (getpoint "Chon diem xuat phat\n"))
  (setq p2 (getpoint p1 "Chon diem ket thuc\n"))
  (command "_Pline" p1 p2 "")
  (setq a1 (Distance p1 p2))
  (or (and a (or (= (type a) 'int) (= (type a) 'real)))
      (setq a 200)
  )
  (setq Caochu 300)
  (or (and hbv (or (= (type hbv) 'int) (= (type hbv) 'real)))
      (setq hbv 10)
  )
  (setq    hbv
     (cond
       ((getreal (strcat "\nduong kinh thep <" (rtos hbv 2 2) ">: ")
        )
       )
       (hbv)
     )
  )
  (setq c (1+ (/ a1 a)))
  (setq p (getpoint "\n Chon diem nhap ket qua" ))
  (entmake
             (list
               (cons 0 "TEXT")
               (cons 10 (list (car p) (cadr p)))
               (cons 40 Caochu)
               (cons
                 1
                 (strcat (rtos c 2 0) "D" (rtos hbv 2 0))
               )
             )
               )

  (AC:TT Caochu)
  (Ac:at2t)
  (SETVAR "clayer" lay)
  (setvar "osmode" luu)
  (princ)
)
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/60478-nh%E1%BB%9D-ch%E1%BB%89nh-s%E1%BB%ADa%C4%91o-chi%E1%BB%81u-d%C3%A0i-v%C3%A0-ghi-ra-text/
(defun AC:TT(Caochu / ss L e)
(vl-load-com)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;(or ans (setq ans 2))
(Alert (strcat "Chon PLine thep\n"))
(setq L (strcat "L= "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))
   )))
   ))
 (setq p (getpoint "\n Chon diem nhap ket qua" ))
  (entmake
             (list
               (cons 0 "TEXT")
               (cons 10 (list (car p) (cadr p)))
               (cons 40 Caochu)
               (cons 1 L
               )
             )
               )
(princ)
)
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/13074-lisp-gh%C3%A9p-text-c%E1%BA%A7n-gi%C3%BAp-%C4%91%E1%BB%A1/?page=2
(defun Ac:at2t (/ center color data edata ent i sel ss str);All Text to Text
 (defun centerSS (ss / lst_max lst_min maxpt minpt ll ur)
   (vl-load-com)
   (foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (vla-GetBoundingBox ent 'minpt 'maxpt)
     (setq lst_min (cons (vlax-safearray->list minpt) lst_min)
    lst_max (cons (vlax-safearray->list maxpt) lst_max)  )   )
   (setq ll (list (car (vl-sort (mapcar 'car lst_min) '<))
       (car (vl-sort (mapcar 'cadr lst_min) '<))  )
  ur (list (last (vl-sort (mapcar 'car lst_max) '<))
       (last (vl-sort (mapcar 'cadr lst_max) '<)) ) )
   (mapcar '/ (mapcar '+ ll ur) '(2.0 2.0 2.0))    )  

 (defun Change_Str (data pt str color)
   (entmake (list (cons 0 "TEXT") (assoc 8 data) (cons 10 pt)
       (cons 11 pt) (assoc 7 data) (assoc 40 data)
       (cons 71 0) (cons 72 1) (cons 73 2)
       (cons 1 str) (cons 62 color)
       (if (assoc 6 data)  (assoc 6 data)  '(6 . "BYLAYER") )
       (if (assoc 39 data) (assoc 39 data) '(39 . 0) )
       (if (assoc 370 data) (assoc 370 data) '(370 . -1) ) ))  )

 (defun dxf (tag obj) (cdr (assoc tag obj)))
;main
 (or *color* (setq *color* 6 ))
 (setq color (getint (strcat "\nNhap so mau cua Text sau khi hoan thanh <" (itoa *color*) "> :")) )
 (if color (setq *color* color) (setq color *color*))
 (setq ss (ssadd))
  (Alert (strcat "Chon Text chieu dai thep truoc\n"))
 (while (setq ent
      (car
        (LM:SelectIf "\nB\U+1EA1n \U+0111\U+00E3 Ch\U+1ECDn Text \U+0111\U+1EC3 N\U+1ED1i: "
          (lambda ( x ) (eq "TEXT" (cdr (assoc 0 (entget (car x)))))) entsel nil
        )
      )
    )   ;(setq sel (entsel "\nChon cac Text can noi voi nhau: "))
   ;(setq ent (car sel))
   (if (= (cdr (assoc 0 (entget ent))) "TEXT")
     (ssadd ent ss)
   )
 )  
 (if (> (sslength ss) 0)
   (progn
     (setq i -1
    str ""
    center (centerSS ss)        
    data (entget (ssname ss 0))        )
     (while (setq ent (ssname ss (setq i (1+ i))))
       (setq edata (entget ent)
         str   (strcat (dxf 1 edata)" " str  )
       )
       (entdel ent)
     )
     (Change_Str data center (substr str 1) color)     )
   (princ "\nKhong chon duoc Text !"))
 (princ))
;===========
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i _  B\U+1EA5m ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng  ch\U+1ECDn kh\U+00F4ng h\U+1EE3p l\U+1EC7.")
)
)
)
)
)
sel
)

@loranypt@huunhantvxdts Mạo muội edit lại như này, hi vọng đúng ý bạn. đúng thì cho xin 1 Like +

<<

2 giờ trước, loranypt đã nói:

>>

2 giờ trước, loranypt đã nói:

@anhGeodesy gần hoàn hảo, nếu dc 1 số điểm sau cần giải quyết:

 

1. xóa đường pl sau khi nhập điểm đầu và cuối

2. cho chọn khoảng cách giữa các thanh thép (hiện tại mặc định đang để 200)

3. sau khi đo chiều dài thép xong add thẳng text vào text đầu được ko khỏi cần bước 3.

 

đã like thanks bác nhiều

;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/175622-y%C3%AAu-c%E1%BA%A7u-k%E1%BA%BFt-h%E1%BB%A3p-lisp/
;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/163324-lisp-r%C3%A3i-th%C3%A9p-s%C3%A0n/
(defun c:sl (/ a1 c)
  (setq luu (getvar "osmode"))
  (setq lay (getvar "clayer"))
  (setq p1 (getpoint "Chon diem xuat phat\n"))
  (setq p2 (getpoint p1 "Chon diem ket thuc\n"))
  ;(setq line (command "_Pline" p1 p2 ""))
  ;(setq a1 (Distance p1 p2))
  (or (and a (or (= (type a) 'int) (= (type a) 'real)))
     (setq a 200)
  (setq a
     (cond
       ((getint (strcat "\nNh\U+1EADp @ r\U+1EA3i th\U+00E9p (K/c R\U+1EA3i) <" (rtos a 2 2) ">: ")
        )
       )
       (a)
     )
  )
  )
  (setq Caochu 300)
  (setq Caochu
     (cond
       ((getint (strcat "\nNh\U+1EADp chi\U+1EC1u cao ch\U+1EEF (Text Hight) <" (rtos Caochu 2 2) ">: ")
        )
       )
       (Caochu)
     )
  )
  (or (and duongkinhthep (or (= (type duongkinhthep) 'int) (= (type duongkinhthep) 'real)))
      (setq duongkinhthep 10)
  )
  (setq    duongkinhthep
     (cond
       ((getreal (strcat "\nNh\U+1EADp \U+0111\U+01B0\U+1EDDng k\U+00EDnh th\U+00E9p <" (rtos duongkinhthep 2 2) ">: ")
        )
       )
       (duongkinhthep)
     )
  )
  (setq c (1+ (/ (Distance p1 p2) a)))
;
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(Alert (strcat "Chon PLine thep\n"))
(setq L 
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))
   )))
   )
  
  ;
  
  (setq p (getpoint "\n Chon diem nhap ket qua" ))
  (entmake
             (list
               (cons 0 "TEXT")
               (cons 10 (list (car p) (cadr p)))
               (cons 40 Caochu)
               (cons
                 1
                 (strcat (rtos c 2 0) "D" (rtos duongkinhthep 2 0) "  L=" (rtos (atof L) 2 0))
               )
             )
               )
  (SETVAR "clayer" lay)
  (setvar "osmode" luu)
  (princ)
)
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i _  B\U+1EA5m ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng  ch\U+1ECDn kh\U+00F4ng h\U+1EE3p l\U+1EC7.")
)
)
)
)
)
sel
)

@loranypt Hi vọng trúng ý bạn. đừng quên cho xin Vote +

<<