Jump to content
InfoFile
Tác giả: vantuan18nd
Bài viết gốc: 200511
Tên lệnh: test
Lisp đo tổng khoảng cách AB + CD nằm trên 2 đường Pline khác nhau

 

:) Thế mới khó lường. Ngắn gọn và xúc tích :D Trong khi đáng ra chỉ cần 1 dòng miêu tả, cũng chẳng cần file bạn...

>>

 

:) Thế mới khó lường. Ngắn gọn và xúc tích :D Trong khi đáng ra chỉ cần 1 dòng miêu tả, cũng chẳng cần file bạn ạ

 

(defun c:test()  (+ (distance (setq a (getpoint "\nA :")) (getpoint a "\nB:"))(distance (setq c(getpoint "\nC:")) (getpoint c "\nD:"))))

Đúng ý em rồi đấy ! Thanks nhiều ! :P


<<

Filename: 200511_test.lsp
Tác giả: vantuan18nd
Bài viết gốc: 200513
Tên lệnh: abde
Lisp đo tổng khoảng cách AB + CD nằm trên 2 đường Pline khác nhau

Bạn thử xem nhé :

(defun c:abde(/ p s)
 (setq s 0)
 (while (setq p (entsel "\n Pick vao doan Pline :"))
(setq s (+ s...
>>

Bạn thử xem nhé :

(defun c:abde(/ p s)
 (setq s 0)
 (while (setq p (entsel "\n Pick vao doan Pline :"))
(setq s (+ s (vlax-curve-getdistatparam (car p) (fix (1+ (vlax-curve-getparamatpoint (car p) (vlax-curve-getClosestPointTo (car p) (cadr p))))))
       	(- (vlax-curve-getdistatparam (car p) (fix (vlax-curve-getparamatpoint (car p) (vlax-curve-getClosestPointTo (car p) (cadr p))))))
   	)
)
(princ s)
 )
 (alert (strcat "Tong L = " (rtos s 2 3)))
 (princ s)
)

Thực ra, chỉ cần 2 cú pick là tính là ra rồi :lol:

Dùng được bạn ạ. Thanks nha


<<

Filename: 200513_abde.lsp
Tác giả: cuongtk2
Bài viết gốc: 426857
Tên lệnh: test
Có bạn nào có lisp đánh theo thứ tự

Nếu bạn định làm dạng nối thêm -1 rồi -2 ... vào số ban đầu thì  code ngắn hơn rất nhiều. Nhưng nếu bạn kết thúc lệnh khi chưa đến số cần thiết thì bạn lại phải làm lại từ đầu đấy.

(defun c:test ( / ent text p1 p11 i textnum)
  (setq ent (entget (car (entsel)))
    text (cdr (assoc 1 ent))
    p1 (cdr (assoc 10 ent))
    p11...
>>

Nếu bạn định làm dạng nối thêm -1 rồi -2 ... vào số ban đầu thì  code ngắn hơn rất nhiều. Nhưng nếu bạn kết thúc lệnh khi chưa đến số cần thiết thì bạn lại phải làm lại từ đầu đấy.

(defun c:test ( / ent text p1 p11 i textnum)
  (setq ent (entget (car (entsel)))
    text (cdr (assoc 1 ent))
    p1 (cdr (assoc 10 ent))
    p11 (cdr (assoc 11 ent))
    i 0)
    (while (setq p2 (getpoint "\nDiem tiep theo:" p1))
    (progn
      (setq i (1+ i)
    textnum (strcat text "-" (rtos i 2 0)))
      (setq ent (subst (cons 10 p2) (assoc 10 ent) ent)
        ent (subst (cons 11 p2) (assoc 11 ent) ent)
        ent (subst (cons 1 textnum) (assoc 1 ent) ent)
        )
      (entmake ent)
      )
    )
  )

 

 


<<

Filename: 426857_test.lsp
Tác giả: Bee
Bài viết gốc: 411099
Tên lệnh: test
Dim Nhanh Giữa Các Line (Hoặc Pl)

 

>>

 

 

Xem cái này sắp xếp thế nào nhé. ^_^

(defun c:test (/ lst old old_osm ss pt lst_dim n p11n)
  (setq lst nil _ang nil)
  (setq old (getvar "DIMJUST"))
  (setq old_osm (getvar 'osmode))
  (if (setq ss (ssget '((0 . "LINE"))))
    (progn
      (command "_zoom" "obj" ss "")
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq
	lst (vl-sort lst
		     '(lambda (e1 e2)
			(> (if (< (cadr (cdr (assoc 10 (entget e1))))
				  (cadr (cdr (assoc 11 (entget e1))))
			       )
			     (cadr (cdr (assoc 10 (entget e1))))
			     (cadr (cdr (assoc 11 (entget e1))))
			   )		;if e1
			   (if (< (cadr (cdr (assoc 10 (entget e2))))
				  (cadr (cdr (assoc 11 (entget e2))))
			       )
			     (cadr (cdr (assoc 10 (entget e2))))
			     (cadr (cdr (assoc 11 (entget e2))))
			   )		;if e2
			)
		      )
	    )
      )					;setq

      (setq pt (polar (cdr (assoc 10 (entget (car lst))))
		      (angle (cdr (assoc 10 (entget (car lst))))
			     (cdr (assoc 11 (entget (car lst))))
		      )
		      (/ (distance (cdr (assoc 10 (entget (car lst))))
				   (cdr (assoc 11 (entget (car lst))))
			 )
			 2
		      )
	       )
      )
      (setvar "DIMJUST" 1)
      (command "DIMUPT" "OFF")
      (command "DIMALIGNED"
	       pt
	       "_per"
	       (cdr (assoc 11 (entget (cadr lst))))
	       "_none"
	       pt
      )
      (setq lst_dim nil)
      (setq lst_dim (cons (entlast) lst_dim))
      (setq n 2)
      (command "DIMBASELINE")
      (repeat (- (length lst) 2)
	(command "_per" (cdr (assoc 11 (entget (nth n lst)))))
	(setq lst_dim (cons (entlast) lst_dim))
	(setq n (1+ n))
      )
      (command "" "")
      (setvar 'osmode 0)      
      (if (lm:clockwise-p
	    (vlax-get (vlax-ename->vla-object (car lst_dim))
		      'textposition
	    )
	    (vlax-get (vlax-ename->vla-object (car lst))
		      'startpoint
	    )
	    (vlax-get (vlax-ename->vla-object (car lst))
		      'endpoint
	    )
	  )
	(setq _ang (+ pi (txt_angle (car lst_dim))))
	(setq _ang (- pi (txt_angle (car lst_dim))))
      )					;if
      (mapcar
	'(lambda (obj)

	   (setq p11n (polar (vlax-get (vlax-ename->vla-object obj)
				       'textposition
			     )
			     _ang
			     (* (getvar 'dimtxt) 10.)
		      )
	   )				;setq
	   (vlax-put (vlax-ename->vla-object obj) 'textposition p11n)
	 )
	lst_dim
      )
    )					;progn then
    (princ "\nBan da khong chon LINE.")
  )					;if
  (command "_zoom" "P")
  (setvar "DIMJUST" old)
  (setvar "OSMODE" old_osm)
  (princ)
)
(defun txt_angle (ename / blkent entdata _angle)
  (if
    (and
      (= (cdr (assoc 0 (setq entdata (entget ename))))
	 "DIMENSION"
      )
      (setq blkent (tblobjname "block" (cdr (assoc 2 entdata))))
    )
     (while (setq blkent (entnext blkent))
       (if (= (cdr (assoc 0 (setq entdata (entget blkent)))) "MTEXT")
	 (setq _angle (cdr (assoc 50 (entget blkent))))
       )
     )
  )
  _angle
)
(defun lm:clockwise-p (p1 p2 p3)
  ((lambda (n) (< (car (trans p2 0 n)) (car (trans p1 0 n))))
    (mapcar '- p1 p3)
  )
)
(princ)

Cơ bản nè Bee :bz  :

(command "DIMALIGNED"

     pt

     "_per"

     (cdr (assoc 11 (entget (cadr lst))))

     "_none"

     pt

)

  1/ Thiếu 1   "_none" truoc pt 

2/ Nên trả lại biến hệ thống diimupt

3/ Nên thêm (setq old_dli (getvar 'dimdli)) ...... (setvar 'dimdli giatri) ...... (setvar "DIMDLI" old_dli) bởi vì nếu dímtyle đã set Dimdli là rất nhỏ (0.75 chẳng hạn)

lúc đó chạy lisp nhìn thử :) 

Vài góp ý nhỏ . Nói chung bạn tuổi trẻ tài cao :)

Hì,

ok mình sẽ rút knghiem. Mình quick code thì chủ yếu xem chạy đc chưa. Nếu ngon lành cần hoàn thiện thì mới thêm các phần khác vào thôi mà. Chủ thớt ko thấy ý kiến nên cứ để vậy thôi.

 

Thanks.


<<

Filename: 411099_test.lsp
Tác giả: vuminhchau
Bài viết gốc: 195128
Tên lệnh: xoay
(Yêu cầu) Xin lisp làm 1 đường thẳng song song với 1 đường thẳng đã chọn

Sửa lại 1 tí cho bạn đây :


(defun c:xoay(/ ST:Geom-Entity-Box-Fast mau Selset tmp)
(vl-load-com)
(defun ST:Geom-Entity-Box-Fast...
>>

Sửa lại 1 tí cho bạn đây :


(defun c:xoay(/ ST:Geom-Entity-Box-Fast mau Selset tmp)
(vl-load-com)
(defun ST:Geom-Entity-Box-Fast (vla-obj /   ll lr ur ul rt)
(vla-getboundingbox vla-obj 'll 'ur)
(cons (mapcar '(lambda (x y) (* (+ x y) 0.5)) (setq ll (vlax-safearray->list ll))(setq ur (vlax-safearray->list ur))) (angle ll ur))
)
(if (and  (princ "\nChon doi tuong mau :")
  (setq mau (ST:Geom-Entity-Box-Fast (vlax-ename->vla-object (ssname (ssget ":S" ) 0))))
  (princ "\nChon cac doi tuong can quay :")
  (ssget)
  (setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
)
(vlax-for object Selset
 (setq typ (vla-get-ObjectName object))
 (vla-rotate object (vlax-3d-point (car (setq tmp (ST:Geom-Entity-Box-Fast object))))
 (-  (cdr mau)
  (cond  ((wcmatch typ "AcDb*Text")
  (vla-get-Rotation object))
 ((wcmatch typ "AcDb*Leader")
  (angle
   (car (setq tmp ((lambda(key lst / l )
     (foreach x lst (if (= key (car x))(setq l (cons (cdr x) l))))
       ) 10 (entget (vlax-vla-object->ename object))))
   )
   (last tmp)
  )
 )
 (T (cdr  tmp))
  )
 )
)
)
(vla-delete Selset)
)
)

 

em dùng lệnh xoay mà bác Tue_NV như hình 2 chỉ quay được chữ, không quay được mũi tên = lệnh LE.

nhờ bác sữa giúp khi dùng lệnh xong nó sẽ quay như hình thứ 3. cảm ơn bác nhiều!

http://www.cadviet.com/upfiles/3/104547_drawing2_1.dwg


<<

Filename: 195128_xoay.lsp
Tác giả: thanhduan2407
Bài viết gốc: 103955
Tên lệnh: aic
Array đối tượng trong vùng
Như vậy thì Lisp chỉ áp dụng với đối tượng dạng điểm như point, Block, Text, Mtext Lisp xử lý nó theo điểm...
>>
Như vậy thì Lisp chỉ áp dụng với đối tượng dạng điểm như point, Block, Text, Mtext Lisp xử lý nó theo điểm chèn phải không bạn?

Trong 3 thao tác của bạn thì Tue_NV thấy thao tác thứ 2 và thao tác thứ 3 : bạn làm không OK lắm

- Thao tác thứ 2 : Ngay ở dòng select object (khi thực thi Lisp), bạn muốn lọc thì Lisp lọc, bạn muốn chọn thì Lisp chọn, không cần thiết phải làm như ý của bạn vì không hiệu quả khi sử dụng vì như bạn nói : nó hơi thừa

- Thao tác thứ 3 : Bạn chọn đối tượng nằm trong, trên hay ngoài vùng chọn => Thực hiện lệnh chọn đối tượng để tuỳ mình xử lý

Đã là chọn Tren rồi thì có cần phải hỏi là "Có chọn cả những đối tượng bị cắt ngang qua hay không ?" Vì đã nằm trên rồi thì đương nhiên Polyline phải cắt qua chứ phải không bạn? Có thể là Tue_NV hiểu chưa được đúng. Bạn nói rõ hơn nhé.

 

Bổ sung thêm 1 ý nữa là Lisp có thể áp dụng cho Spline kín chứ không riêng gì Polyline

Tue_NV đang bận. Lúc rãnh mới có thể viết Lisp được

 

@Anh Duy : Tue_NV mới thấy bài của anh hôm qua, sao anh vội del đi thế?

Nếu anh thấy các hàm vl khó hiểu thì Tue_NV viết code này, không có sử dụng hàm vl, hy vọng anh Duy và bạn thanhDuan dễ hiểu hơn :

Đây là code :

(defun c:aic(/ oldos pl name kc minp maxp minpp from cur end ins fl)
 (command "undo" "be")
 (setvar "attreq" 0)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq pl (car(entsel "\n Pick chon Polyline kin :")))
 (setq name (getstring t "\n Nhap ten Block / Enter de chon Block :"))
 (if (= name "") (setq name (cdr(assoc 2 (entget (car(entsel "\n Pick chon Block :")))))))
 (setq kc (getdist "\n Nhap khoang cach :"))
 (setq minp (car (ACET-GEOM-EXTENTS pl)))
 (setq maxp (cadr (ACET-GEOM-EXTENTS pl)))
 (setq minpp (mapcar '- minp
	         (list (setq dist (distance maxp minp)) dist 0.0)
      )
 )
 (command "insert" name minp 1 1 0)
 (setq from (entlast) ss (ssadd))
 (command "array" "L" "" "R"
   (1+ (fix (/ (- (car maxp) (car minp)) kc)))
   (1+ (fix (/ (- (car maxp) (car minp)) kc)))
   kc kc
 )
   (setq end (entlast) cur from)
(initget "N T")
 (setq ans (getkword "\n Ban muon xoa doi tuong Trong hay Ngoai duong bao < N / T > :"))
 (while (or fl (not (eq cur end)))
   (setq ins (cdr(assoc 10 (entget cur))))
   (command "line" minpp ins "")
   (if (= ans "N")
   	(if (= (rem (length (ACET-GEOM-INTERSECTWITH (entlast) pl 0)) 2) 0)
     		(entdel cur)
       )
       (if (= (rem (length (ACET-GEOM-INTERSECTWITH (entlast) pl 0)) 2) 1)
     		(entdel cur)
       )
   )
     (entdel (entlast))
(setq cur (entnext cur))
       (if (eq cur end) (progn (setq fl t) ;(setq cur end))		 
)
 )

 (command "undo" "end")
 (setvar "osmode" oldos)
)

Trong Code có sử dụng hàm (ACET-GEOM-EXTENTS ent) : hàm trả về điểm min và max của ent trong 1 list

Ví dụ : (ACET-GEOM-EXTENTS (car(entsel)))

 

Hàm (ACET-GEOM-INTERSECTWITH en1 en2 flag)

Hàm trả về listpoint tọa độ các điểm giao của 2 đối tượng en1 en2.

flag là số interger, cờ quy định các kiểu giao:

- 0: không mở rộng 2 đối tượng en1 en2

- 1: mở rộng đối tượng en1, không mở rộng đối tượng en2.

- 2: không mở rộng đối tượng en1, mở rộng đối tượng en2.

- 3: mở rộng 2 đối tượng en1 en2

 

Trong code trên thì Tue_NV đã sử dụng kiểu cờ flag=0

Các hàm này nằm trong phụ trợ Express

Cảm ơn bác Tue_NV rất nhiều, mặc dù bác rất bận nhưng vẫn tham gia góp ý kiến.

Đúng là thao tác thứ 3 của em hơi ko OK. Em xin đính chính lại là : Bạn chọn đối tượng nằm trong hay ngoài vùng chọn .

Cảm ơn bác nhiều vì đã thay hàm và giải thích rõ ràng. Lisp của bác chạy rất OK. Mong bác lúc nào rảnh có thể giải đáp được bài toán. Mong tin bác

Em muốn lấy tất cả các đối tượng được chọn, không phải chỉ dạng điểm (trường hợp cắt ngang qua thì xét riêng)

Em luôn lắng nghe và chờ đợi ý kiến phản hồi.


<<

Filename: 103955_aic.lsp
Tác giả: thanhduan2407
Bài viết gốc: 103965
Tên lệnh: aic
Array đối tượng trong vùng
Như vậy thì Lisp chỉ áp dụng với đối tượng dạng điểm như point, Block, Text, Mtext Lisp xử lý nó theo điểm...
>>
Như vậy thì Lisp chỉ áp dụng với đối tượng dạng điểm như point, Block, Text, Mtext Lisp xử lý nó theo điểm chèn phải không bạn?

Trong 3 thao tác của bạn thì Tue_NV thấy thao tác thứ 2 và thao tác thứ 3 : bạn làm không OK lắm

- Thao tác thứ 2 : Ngay ở dòng select object (khi thực thi Lisp), bạn muốn lọc thì Lisp lọc, bạn muốn chọn thì Lisp chọn, không cần thiết phải làm như ý của bạn vì không hiệu quả khi sử dụng vì như bạn nói : nó hơi thừa

- Thao tác thứ 3 : Bạn chọn đối tượng nằm trong, trên hay ngoài vùng chọn => Thực hiện lệnh chọn đối tượng để tuỳ mình xử lý

Đã là chọn Tren rồi thì có cần phải hỏi là "Có chọn cả những đối tượng bị cắt ngang qua hay không ?" Vì đã nằm trên rồi thì đương nhiên Polyline phải cắt qua chứ phải không bạn? Có thể là Tue_NV hiểu chưa được đúng. Bạn nói rõ hơn nhé.

 

Bổ sung thêm 1 ý nữa là Lisp có thể áp dụng cho Spline kín chứ không riêng gì Polyline

Tue_NV đang bận. Lúc rãnh mới có thể viết Lisp được

 

@Anh Duy : Tue_NV mới thấy bài của anh hôm qua, sao anh vội del đi thế?

Nếu anh thấy các hàm vl khó hiểu thì Tue_NV viết code này, không có sử dụng hàm vl, hy vọng anh Duy và bạn thanhDuan dễ hiểu hơn :

Đây là code :

(defun c:aic(/ oldos pl name kc minp maxp minpp from cur end ins fl)
 (command "undo" "be")
 (setvar "attreq" 0)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq pl (car(entsel "\n Pick chon Polyline kin :")))
 (setq name (getstring t "\n Nhap ten Block / Enter de chon Block :"))
 (if (= name "") (setq name (cdr(assoc 2 (entget (car(entsel "\n Pick chon Block :")))))))
 (setq kc (getdist "\n Nhap khoang cach :"))
 (setq minp (car (ACET-GEOM-EXTENTS pl)))
 (setq maxp (cadr (ACET-GEOM-EXTENTS pl)))
 (setq minpp (mapcar '- minp
	         (list (setq dist (distance maxp minp)) dist 0.0)
      )
 )
 (command "insert" name minp 1 1 0)
 (setq from (entlast) ss (ssadd))
 (command "array" "L" "" "R"
   (1+ (fix (/ (- (car maxp) (car minp)) kc)))
   (1+ (fix (/ (- (car maxp) (car minp)) kc)))
   kc kc
 )
   (setq end (entlast) cur from)
(initget "N T")
 (setq ans (getkword "\n Ban muon xoa doi tuong Trong hay Ngoai duong bao < N / T > :"))
 (while (or fl (not (eq cur end)))
   (setq ins (cdr(assoc 10 (entget cur))))
   (command "line" minpp ins "")
   (if (= ans "N")
   	(if (= (rem (length (ACET-GEOM-INTERSECTWITH (entlast) pl 0)) 2) 0)
     		(entdel cur)
       )
       (if (= (rem (length (ACET-GEOM-INTERSECTWITH (entlast) pl 0)) 2) 1)
     		(entdel cur)
       )
   )
     (entdel (entlast))
(setq cur (entnext cur))
       (if (eq cur end) (progn (setq fl t) ;(setq cur end))		 
)
 )

 (command "undo" "end")
 (setvar "osmode" oldos)
)

Trong Code có sử dụng hàm (ACET-GEOM-EXTENTS ent) : hàm trả về điểm min và max của ent trong 1 list

Ví dụ : (ACET-GEOM-EXTENTS (car(entsel)))

 

Hàm (ACET-GEOM-INTERSECTWITH en1 en2 flag)

Hàm trả về listpoint tọa độ các điểm giao của 2 đối tượng en1 en2.

flag là số interger, cờ quy định các kiểu giao:

- 0: không mở rộng 2 đối tượng en1 en2

- 1: mở rộng đối tượng en1, không mở rộng đối tượng en2.

- 2: không mở rộng đối tượng en1, mở rộng đối tượng en2.

- 3: mở rộng 2 đối tượng en1 en2

 

Trong code trên thì Tue_NV đã sử dụng kiểu cờ flag=0

Các hàm này nằm trong phụ trợ Express

Các đối tượng không nằm so le nhau và tốc độ chậm hơn so với lần trước bác Tue_NV à.

Nhưng em dễ hiểu hơn


<<

Filename: 103965_aic.lsp
Tác giả: thanhduan2407
Bài viết gốc: 104169
Tên lệnh: copyblk
Array đối tượng trong vùng
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 :

statusbar.gif

 

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)

Cảm ơn bác Gia_Bach rất nhiều. Lisp của bác chạy rất ổn và thêm một phần trực quan khi chương trình đang chạy (tránh tình trạng nghĩ máy bị đơ).

Cám ơn bác nhiều.

Đến khi nào em mới được bằng các bác đây. Em sẽ cố gắng học hỏi, mong các bác giúp đỡ. Cảm ơn các bác rất nhiều


<<

Filename: 104169_copyblk.lsp
Tác giả: daotukl
Bài viết gốc: 39877
Tên lệnh: cbl
insert block theo khoảng cách cho trước và nằm giữa hai điểm
lệnh là CBL (Chèn BLock)

- Lúc chương trình hỏi tên block: nếu bạn muốn tên giống lần dùng lệnh trước đó chỉ cần nhấn enter, nếu bạn không nhớ tên block hãy...

>>
lệnh là CBL (Chèn BLock)

- Lúc chương trình hỏi tên block: nếu bạn muốn tên giống lần dùng lệnh trước đó chỉ cần nhấn enter, nếu bạn không nhớ tên block hãy nhập * rồi enter để pick vào 1 block trên màn hình.

- Lúc chương trình hỏi khoảng cách: nếu bạn không nhớ khoảng cách giữa 2 block là bao nhiêu, chỉ nhớ là có k khoảng nằm giữa hai điểm, bạn chỉ cần nhập -k. Ví dụ nếu bạn muốn divide khoảng giữa hai điểm là 5 khoảng, bạn nhập vào -5. K không nhất thiết phải là số nguyên, bạn có thể nhập vào -4.5.

 

(defun c:cbl( / tmp ok p1 p2 kc cur l)
 (princ "\nCBL - free lisp from CADViet.com")
 (if (not bln) (setq bln "*"))
 (while (not ok)
    (setq tmp (getstring t (strcat "\nTen block, nhap dau * de pick block: <" (if bln bln "") ">: "))
   tmp (if (or (not tmp) (= tmp "")) bln tmp)
   ok (or (tblsearch "block" tmp) (= tmp "*"))
    )
    (if (not ok) (alert (strcat "Khong co block " (if tmp tmp ""))))
 )

 (if (= tmp "*") (setq tmp (cdr (assoc 2 (entget (car (entsel "\nHay pick vao block: ")))))))

 (setq p1 (getpoint "\nHay vao diem thu nhat: ")
p2 (trans (getpoint p1 "\nHay vao diem thu hai: ") 1 0)
kc (getdist p1 "\nHay vao khoang cach: ")
       p1 (trans p1 1 0)
 )

 (setq bln tmp
cur 0.0
a (angle p1 p2)
l (distance p1 p2)
 )  
 (if (< kc 0) (setq kc (/ l kc -1.0)))
 (while (> l (+ cur 0.001))
   (entmake (list (cons 0 "insert") (cons 10 (polar p1 a cur)) (cons 2 bln)))
   (setq cur (+ cur kc))
 )
 (entmake (list (cons 0 "insert") (cons 10 (polar p1 a l)) (cons 2 bln)))
 (princ)
)

bác hoành ơi em muốn hai đầu nó có khoảng trống (khoảng trống đó <=1/2@)

thanks bác rất nhiều


<<

Filename: 39877_cbl.lsp
Tác giả: ketxu
Bài viết gốc: 420703
Tên lệnh: l%E1%BB%87nh c%E1%BB%A7a b%E1%BA%A1n
Đánh cos cao độ tự động

Bạn tạo một lisp với nội dung là :

(defun c:Lnh_ca_bn()(c
>>

Bạn tạo một lisp với nội dung là :

(defun c:Lnh_ca_bn()(c:dccd))

 


<<

Filename: 420703_l%E1%BB%87nh_c%E1%BB%A7a_b%E1%BA%A1n.lsp
Tác giả: sukhoi47
Bài viết gốc: 367460
Tên lệnh: at2t
Lisp Ghép Text Cần Giúp Đỡ

Cật nhật theo yêu cầu : Nối text theo thứ tự các text được chọn.

(defun c:at2t (/ center...
>>

Cật nhật theo yêu cầu : Nối text theo thứ tự các text được chọn.

(defun c: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))  (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 str " " (dxf 1 edata))  )	(entdel ent)	)      (Change_Str data center (substr str 2) color)     )    (princ "\nKhong chon duoc Text !"))  (princ))



bác có thể giúp em sửa lại lisp này thêm chức nặng tự động thêm dấu ; giữa các text không ạ, chân thành cảm ơn  bác


<<

Filename: 367460_at2t.lsp
Tác giả: thainguyen_tg
Bài viết gốc: 374796
Tên lệnh: cte
Lisp đổi màu text sau khi sửa

 

Vậy bạn dùng lisp này:

(defun c:CTE (/ mausac mouse cont contt ent)
(vl-load-com)
(setq mausac "1") ; thay doi...
>>

 

Vậy bạn dùng lisp này:

(defun c:CTE (/ mausac mouse cont contt ent)
(vl-load-com)
(setq mausac "1") ; thay doi mau o day
(setq mouse nil)
(prompt "\n Chon doi tuong :")
(while (/= (car mouse) 2)
(setq mouse (grread 0 15 2))
(if (= (car mouse) 3)
(if (and (setq ent (nentselp (cadr mouse)))
         (or (wcmatch (cdr(assoc 0 (entget (car ent)))) "*TEXT")
          (eq (type (last ent)) 'ENAME)
)
     )
   (progn
(if (and (wcmatch (cdr(assoc 0 (entget (car ent)))) "*TEXT") (null (eq (type (car (last ent))) 'ENAME)))
   (progn (setq cont (cdr(assoc 1 (entget (setq ent (car ent)))))) (command ".ddedit" ent ""))
   (progn (setq cont (vlax-get (vlax-ename->vla-object (setq ent (car (last ent)))) 'TextOverride)) (command ".ddedit" ent ""))
)
(princ "\n doi tuong duoc pick chon/ENTER ke ket thuc chon")
 
(if (and (wcmatch (cdr(assoc 0 (entget ent))) "*TEXT") (null (eq (type ent) 'ENAME)))
      (if (/= (cdr(assoc 1 (entget ent))) cont)
       (command ".chprop" ent "" "c" mausac "")
      )
)
(if (eq (type ent) 'ENAME)
 (if (= (cdr(assoc 0 (entget ent))) "DIMENSION")
   (if (/= (vlax-get (vlax-ename->vla-object ent) 'TextOverride) cont)
    ;(command ".ddedit" ent "" ".DIMOVERRIDE" "dimclrt" mausac "" ent "") )
(command ".DIMOVERRIDE" "dimclrt" mausac "" ent "") )
   )
)
(princ "\nChon doi tuong")
)
)
)
)
(princ)
)

Do nhu cầu công việc mình thấy lsp này rất tiện ích cho công việc của mình, nhưng không biết các sửa thêm tính năng như thế nào? Mong bạn Tue_NV hoặc các bạn trên diễn đàn ai biết giúp mình với: khi gõ lệnh CTE và ta chỉ chạm text hoặc dim(tất cả đều chưa sữa) thì các text và dim đó đều đổi màu(đổi sang màu số 9). Thanks các bạn


<<

Filename: 374796_cte.lsp
Tác giả: pphung183
Bài viết gốc: 376381
Tên lệnh: k
Lisp đổi màu text sau khi sửa
(Defun c:k()
(while
(setq cmd (getvar "cmdecho"))
(setq osm (getvar "osmode"))
(setq nbc (getvar "clayer"))
	(setvar "cmdecho"...
>>
(Defun c:k()
(while
(setq cmd (getvar "cmdecho"))
(setq osm (getvar "osmode"))
(setq nbc (getvar "clayer"))
	(setvar "cmdecho" 0)
	(command "osnap" "none")
	(initget "Heso Do")
	(setq pt (getpoint "\n HE SO / < CHON DIEM>: "))
   	(if (= pt "Heso")
	    	(progn	
			(setq am (getreal " HE SO: "))
			(if (and (null am) (/= ac 0))
				(setq am ac)
			)
		(setq pt (getpoint "\n CHON DIEM: "))	
		)
		(setq ac am))
			
	(if (or (= am 0) (null am)) (setq am 1))
	(setq s 0)
	(progn 
;		(setq pt (getpoint "\n CHON DIEM: "))	
	      (while pt
			(setq entold (cdr (assoc 5 (entget (entlast)))))
			(command "boundary" pt "")
			(setq entnew (cdr (assoc 5 (entget (entlast)))))
			(if (/= entold entnew)    
				(progn 
                        	(setq entnew (entget (entlast)))
                        	(if (assoc 62 entnew)
                          		(setq entnew (subst (cons 62 (+ 3 (cdr (assoc 62 entnew)))) (assoc 62 entnew) entnew))
                          		(setq entnew (append entnew (list (cons 62 (+ 3 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 entnew))))))))))
                          	)
				
                          
                        	(entmod entnew)
                        	(Command "area" "o" (entlast))
					(setq s (+ s (getvar "area")))
   					(setq pt (getpoint "\n CHON DIEM: "))
					(entdel (entlast))
	        		)
				(progn
					(princ "CHON DIEM SAI")
					(setq pt (getpoint "\n CHON DIEM: "))
				)
			)
		  )

            )
	(PRINt " CHON TEXT CAP NHAT KHOI LUONG")
	(SETQ SS1 (SSGET))
	(SETQ DS (ENTGET (SSNAME SS1 0)))
	(SETQ ND (CDR (ASSOC 1 DS)))
	(SETQ LCT (STRLEN ND))
	(SETQ DEM 1)
	(SETQ DEM1 1)
	(WHILE (< DEM LCT)
		(PROGN
			(SETQ BT (SUBSTR ND DEM 1))
			(IF (= BT "=") (SETQ DEM1 DEM) (SETQ DEM1 (+ DEM1 1)))
			(IF (= BT "=") (SETQ DEM LCT) (SETQ DEM (+ DEM 1)))
		)
	)	
	(SETQ ND1 (SUBSTR ND 1 DEM1))
	(SETQ ND2 (RTOS (* S AM) 2 2))
	(SETQ ND3 (STRCAT ND2))
	(SETQ NDM (CONS 1 ND3))
	(SETQ NDC (CONS 1 ND))
	(SETQ DS (SUBST NDM NDC DS))
	(ENTMOD DS)
(setvar "cmdecho" cmd)
(setvar "clayer" nbc)
(setvar "osmode" osm)
(princ (* s am))
)
)

bạn có thể sửa hộ mình lisp này sau khi cập nhật khối lượng tự động đổi màu của text luôn được không. cảm ơn bạn nhiều

 

Vì Lisp này phục vụ cho nhu cầu riêng của bạn nên muốn nhanh thì hãy đính kèm bản vẽ thể hiện ý muốn :) .


<<

Filename: 376381_k.lsp
Tác giả: trinhngoctri
Bài viết gốc: 376487
Tên lệnh: cte
Lisp đổi màu text sau khi sửa

 

Vậy bạn dùng lisp này:

(defun c:CTE (/ mausac mouse cont contt ent)
(vl-load-com)
(setq mausac "1") ; thay doi...
>>

 

Vậy bạn dùng lisp này:

(defun c:CTE (/ mausac mouse cont contt ent)
(vl-load-com)
(setq mausac "1") ; thay doi mau o day
(setq mouse nil)
(prompt "\n Chon doi tuong :")
(while (/= (car mouse) 2)
(setq mouse (grread 0 15 2))
(if (= (car mouse) 3)
(if (and (setq ent (nentselp (cadr mouse)))
         (or (wcmatch (cdr(assoc 0 (entget (car ent)))) "*TEXT")
          (eq (type (last ent)) 'ENAME)
)
     )
   (progn
(if (and (wcmatch (cdr(assoc 0 (entget (car ent)))) "*TEXT") (null (eq (type (car (last ent))) 'ENAME)))
   (progn (setq cont (cdr(assoc 1 (entget (setq ent (car ent)))))) (command ".ddedit" ent ""))
   (progn (setq cont (vlax-get (vlax-ename->vla-object (setq ent (car (last ent)))) 'TextOverride)) (command ".ddedit" ent ""))
)
(princ "\n doi tuong duoc pick chon/ENTER ke ket thuc chon")
 
(if (and (wcmatch (cdr(assoc 0 (entget ent))) "*TEXT") (null (eq (type ent) 'ENAME)))
      (if (/= (cdr(assoc 1 (entget ent))) cont)
       (command ".chprop" ent "" "c" mausac "")
      )
)
(if (eq (type ent) 'ENAME)
 (if (= (cdr(assoc 0 (entget ent))) "DIMENSION")
   (if (/= (vlax-get (vlax-ename->vla-object ent) 'TextOverride) cont)
    ;(command ".ddedit" ent "" ".DIMOVERRIDE" "dimclrt" mausac "" ent "") )
(command ".DIMOVERRIDE" "dimclrt" mausac "" ent "") )
   )
)
(princ "\nChon doi tuong")
)
)
)
)
(princ)
)

Sao tôi Ap xong rồi đánh lênh CTE mà nó không hiểu j vậy bạn.


<<

Filename: 376487_cte.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 219529
Tên lệnh: chia
cắt pline thành các đoạn theo chiểu dài chọn

16h ~ 100 dòng code, vị chi là 16*60/100 = mất 9.6 phút cho 1 dòng code, hơi bị lâu hén. Đùa tí thôi, định trả lời bài này giống...

>>

16h ~ 100 dòng code, vị chi là 16*60/100 = mất 9.6 phút cho 1 dòng code, hơi bị lâu hén. Đùa tí thôi, định trả lời bài này giống vndesperados, nhưng vndes đã trả lời vậy rồi, mình trả lời giống lại thành spam bài kiểu Jikibo. Đành phải trả lời khác vậy.

 

Lệnh CHIA dưới đây sẽ làm điều dnhqs muốn (measure sau đó thì break một cách tự động):

(defun c:chia( / ent kc oldos)  (defun findp(ent)    (vlax-curve-getPointAtDist ent kc)  )  (setq ent (car (entsel "\nVao doi tuong: "))	kc (getdist "\nVAo khoang cach: ")	oldos (getvar "osmode")  )  (setvar "osmode" 0)  (while (and (setq p (findp ent)) (not (equal p oldp 0.01)))    (command ".break" ent p p)    (setq ent (entlast)  	oldp p)  )  (setvar "osmode" oldos)  (princ))

Các bác cho hỏi thêm đoạn code nào để sau khi chia Lisp tự nối các đoạn thành PL (Nghĩa là PL để chia không bị break)

Cám ơn !


<<

Filename: 219529_chia.lsp
Tác giả: dunguss3581
Bài viết gốc: 199208
Tên lệnh: gifpr
viết lisp lấy tọa độ điểm và tên điểm

Hề hề hề,

Đây là cái lisp mình chỉnh lại theo hướng các bác Tue_NV và Ketxu đã góp ý. Hy vọng nó sẽ nhanh hơn cái lisp...

>>

Hề hề hề,

Đây là cái lisp mình chỉnh lại theo hướng các bác Tue_NV và Ketxu đã góp ý. Hy vọng nó sẽ nhanh hơn cái lisp cũ. Rất mong các bác test và cho ý kiến.

(defun c:gifpr (/ ss n plst i en el p ma k tmp fw)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ss (ssget (list (cons 0 "acad_proxy_entity")))
         n (sslength ss)
         plst (list)
         i 0)

(setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv" 1))
(if tmp
   (progn
        	(setq fw (open tmp "w") )
        	(command "undo" "be")
        	(while (< i n)

                	(setq en (entlast))
                	(command "explode" (ssname ss i))
                	(while (setq en (entnext en))
                               (setq el (entget en))
                               (if (= (cdr (assoc 0 el)) "CIRCLE")
                                   (setq p (cdr (assoc 10 el)))
                               )
                          	(if (= (cdr (assoc 0 el)) "MTEXT")
                              	(progn
                                         (setq p1 (cdr (assoc 10 el)))
                                         (if (equal (- (cadr p) (cadr p1)) 0.15 0.001)
                                             (setq ma (cdr (assoc 1 el)))
                                         )
                              	)
                               )
                     )
                     (setq k (ACET-STR-FIND "\\l" ma))
                     (setq ma (substr ma (+ k 2) ))
                     (setq   i (1+ i))
                     (setq str (strcat (itoa i) (chr 44) ma (chr 44) (rtos (car p) 2 2) (chr 44) (rtos (cadr p) 2 2) (chr 44) (rtos (caddr p) 2 2)) )
                     (write-line str fw)
           )
           (command "undo" "e")
           (command "undo" 1)            
           (close fw)
	)
)
(princ)
)

 

@ bác chủ thớt: Theo ngu ý của mình thì có thể trong cái gọi là TOPO của bác nó không có đối tượng là Acad_proxy_entity bác ạ. Đối tượng này chỉ khi xuất từ Topo sang Cad nó mới tạo thành. Bởi thế nên cái thằng ssget nó chả nhận được thằng cu tí nào cả.

Do mình chả biết cái chi về thằng Topo này nên chỉ đoán mò theo cái kết quả mà bác đưa ra. Trúng hay trật thì các bác đừng trách.

Nếu quả đúng vậy thì tại sao bác chủ thớt lại cứ nhất thiết phải chạy lisp trên nền Topo nhỉ?? Nếu chạy trong CAD rồi trả cái kết quả về Topo thì không được ư??? Mình cứ thiển nghĩ rằng nếu thằng Topo xuất được sang CAd thì ắt phải có cách xuất ngược từ CAd về Topo để xử lý.

Mặt khác cái đích cuối cùng bác cần là cái chi?? Nếu sử dụng cái kết quả của lisp này thì có vấn đề gì không thỏa mãn cho cái đích cuối cùng ấy. Hay chỉ là vấn đề bác không thích dùng do nó không chạy được với Topo???

Mình thì cho rằng cái cần là cái đích đó, đi bằng cách nào, làm bằng cách chi mà đạt được cái đích đó thì cho dù nó có hơi chậm cũng còn hơn ngồi chờ cách tối ưu thỏa mãn cái ý thích của mình mà chửa biết lúc nào có được.

Chừng nào bác có được cái tối ưu bác cần có thể bác hãy chia sẻ cái đó để anh em được học hỏi thêm chút chút bác nhé.

Chúc bác vui.

sao tui dùng không được báo lỗi này: (acet-str-find <find> <string> ])

; error: ADS request error

các bác xem giúp tui mò không ra.


<<

Filename: 199208_gifpr.lsp
Tác giả: BigBill
Bài viết gốc: 57080
Tên lệnh: chentext
Lisp gán text vào polyline
Chào bạn BigBill,

Bạn dùng thử lisp này, nếu có gì chưa ổn thì post lên nhé.

(defun c:chentext ()
(vl-load-com)
(setq osn (getvar...
>>
Chào bạn BigBill,

Bạn dùng thử lisp này, nếu có gì chưa ổn thì post lên nhé.

(defun c:chentext ()
(vl-load-com)
(setq osn (getvar "osmode"))
(setvar  "osmode" 0)
(setq dt (car (entsel "\n Chon duong Polyline"))
  text (getstring "\n Nhap gia tri cao do: ")
  pc (getpoint "\n Chon vi tri cao do:")
  dis (vlax-curve-getdistatpoint dt pc)
  par (vlax-curve-getparamatdist dt dis)
  vtt (vlax-curve-getFirstderiv dt par)
  h (getreal "\n Nhap chieu cao text: ")
)
(if (/= (car vtt) 0)
(setq gr (atan (/ (cadr vtt) (car vtt))))
)
(setq gd (* gr (/ 180 pi)))
(command "text" (list (- (car pc) (* (/ h 3)  (sin gr))) (+ (cadr pc) (* (/ h 3)  (cos gr)))) h gd text)
(setvar "osmode" osn)
(princ)
)

 

Chúc bạn vui.

Cám ơn bạn ! Mình đã dùng thử lisp của bạn và vướng phải những lỗi sau :

-Giá trị text cao độ khi in ra màn hình không đúng với giá trị mà mình đã nhập, và thực tế cao độ của đường Polyline đó vẫn là 0, không thay đổi.

-Sau khi dùng lisp thì mất hết chế độ bắt điểm.

-Vị trí của text không đúng như mình muốn, tức là chiều của text không cùng với chiều của Polyline.Khoảng cách từ text đến Polyline cũng vậy.

Mong bạn tìm hiểu thêm và hoàn thiện Lisp ! Chào bạn


<<

Filename: 57080_chentext.lsp
Tác giả: taipham
Bài viết gốc: 384241
Tên lệnh: rpl2
Nhờ Sửa Lisp Replace Text Nhanh

 

Có thể lỗi do code cũ hay ... mình không muốn "đột nhập" :D

Chỉ có thể sửa cho bạn thế này thôi :

>>

 

Có thể lỗi do code cũ hay ... mình không muốn "đột nhập" :D

Chỉ có thể sửa cho bạn thế này thôi :

(defun c:rpl2()
    (setq olsosmode (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (setq p (ssget))  
    (if p
 (progn
            (setq osl (strlen (setq os (H:get-string "Old string "))))
            (setq nsl (strlen (setq ns (H:get-string "New string "))))
     (setq l 0 chm 0 n (sslength p))
     (setq adj
  (cond
      ((/= osl nsl) (- nsl osl))
      (T nsl)
  )
     )
 (while (< l n)                  
     (setq d (entget (setq e (ssname p l))))
     (if (and (= (atext 0) "INSERT")(= (atext 66) 1))
  (progn
      (setq e (entnext e))
      (while e
   (setq d (entget e))
   (cond
       ((= (atext 0) "ATTRIB")
    (setq chf nil si 1)
    (setq s (cdr (setq as (assoc 1 d))))
    (while (= osl (setq sl (strlen
        (setq st (substr s si osl)))))
        (cond
     ((= st os)
         (setq s (strcat (substr s 1 (1- si)) ns
         (substr s (+ si osl))))
         (setq chf t)
         (setq si (+ si adj))
     )
        )
    (setq si (1+ si))
       )
       (if chf
    (progn       
        (setq d (subst (cons 1 s) as d))
        (entmod d)       
        (entupd e)       
        (setq chm (1+ chm))
    )
       )
       (setq e (entnext e))
       )
       ((= (atext 0) "SEQEND")
    (setq e nil))
       (T (setq e (entnext e)))
                        )
      )
  )
     )
            (if (= "MTEXT"            ; Look for MTEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (if (= "DIMENSION"            ; Look for DIMENSION entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (if (= "TEXT"            ; Look for TEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (setq l (1+ l))
 )
 )
    )
    (if (> chm 1)
       (princ (strcat "\nUpdated " (itoa chm) " text strings"))
       (princ (strcat "\nUpdated " (itoa chm) " text string"))
    )
    (setvar "OSMODE" oldosmode)
    (terpri)
)
;
(defun atext (num)
   (cdr (assoc num d))
)
;;==================
(defun H:get-string(show /  str text)
 (cond ((> (strlen (setq str (getstring (strcat "\n" show " <Pick>: ") T))) 0) str)
    ((while (not text)
    (prompt "\nPick: ")
    (setq text (ssget "+.:E:S" '((0 . "*TEXT"))))
    )
   (setq str (cdr (assoc 1 (entget (ssname text 0))))))
 )
)

OKE, thế này là quá oke rồi anh, cảm ơn anh nhiều nhé! chúc anh và diễn đàn luôn thành công! :))


<<

Filename: 384241_rpl2.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 166224
Tên lệnh: 2layer
Lisp gom đối tượng dựa vào mã màu

@bác Gia_bach : ngắn gọn và đẹp quá ^^

@t031285 : Bạn phải tự định nghĩa vào list màu - đối tượng trong list lst :

Ví dụ, bạn...

>>

@bác Gia_bach : ngắn gọn và đẹp quá ^^

@t031285 : Bạn phải tự định nghĩa vào list màu - đối tượng trong list lst :

Ví dụ, bạn muốn thêm màu 3, layer 3 thì thêm vào dòng (cons 3 "3") sau dòng màu đỏ :

 

(defun c:2layer(/ actDoc col layObj lst)
(setq lst 
(list 
(cons 1 "test1")
(cons 2 "test2")
      ;Thêm list tương ứng vào đây
)
)
(setq actDoc (vla-get-activedocument (vlax-get-acad-object)  )
layObj (vla-get-layers  actDoc  )  )
 (vlax-for lay (vla-get-layouts actDoc)
   (vlax-for obj (vla-get-block lay)      
     (if (and (/= (setq col (vla-get-ColorIndex(vla-get-truecolor obj))) 0)
       (/= col 256)
	   (assoc col lst))
(progn
  (if (not (tblsearch "layer" (cdr(assoc col lst))))
    (vla-Add layObj (cdr (assoc col lst))))
  (vla-put-layer obj (cdr (assoc col lst))))))))

 

@Nguyenkhoadng : bạn post bài sai quy định, lần này mình sửa, hy vọng bạn không phiền lòng và rút kinh nghiệm :)

Hề hề hề,

Làm kiểu này thì phải chịu khó ngồi thống kê tất cả các màu hiện có trên bản vẽ để tạo ra cái lst, e phi bác t031285 chả ai có thể làm được.

Hề hề hề,...

Bác thử tính cái kiểu tạo vòng lặp và cho người dùng tự chọn nhập tên layer xem sao. (có bao nhiêu màu thì nhập bấy nhiêu tên, thoải mái đặt tên Tí tèo hay eo ếch gì cũng được) ......

Hề hề hề,.....


<<

Filename: 166224_2layer.lsp
Tác giả: duy782006
Bài viết gốc: 196628
Tên lệnh: pb
Lisp tạo block không cần đặt tên

Nếu dùng Command thì :

(defun c:pb ()(command "cutclip" (ssget ) ""...
>>

Nếu dùng Command thì :

(defun c:pb ()(command "cutclip" (ssget ) "" "pasteblock"))

Làm vậy phải chọn điểm chèn lại ra với lại ko kiểm soát được điểm này bác két ơi.


<<

Filename: 196628_pb.lsp

Trang 269/304

269