Hề hề hề,

Gửi bạn cái ni, không biết đã đúng ý bạn chưa??? Lưu ý rằng 3 text mà bạn chọn phải là 3 text có...

>>

 

Hề hề hề,

Gửi bạn cái ni, không biết đã đúng ý bạn chưa??? Lưu ý rằng 3 text mà bạn chọn phải là 3 text có giá trị của cao độ và đặt tại điểm ghi cao độ đó.

(defun c:ns	(/ ss3 pgoc lste tt)   (princ "\nChon 3 text dau tien: ")   (setq ss3 (ssget '((0 . "TEXT"))))   (if (/= (sslength ss3) 3)	  (alert (strcat "\nBan vua chon "					 (itoa (sslength ss3))					 " text\nban can phai chon 3 text"			 )	  )	  (progn		 (setq			pgoc (trans (getpoint "\nVao diem noi suy: ") 1 0)			lste (mapcar 'ssname (list ss3 ss3 ss3) '(0 1 2))			tt	 (entget (car lste))			lste (mapcar '(lambda (e)							 (setq tt (entget e)								   p  (cdr (assoc 10 tt))								   gt (atof (cdr (assoc 1 tt)))							 )							 (reverse (cons gt (cdr (reverse p))))						  )						 lste				 )		 )		 (mapcar 'set '(p0 p1 p2) lste)		 (setq tt (subst (cons 10 pgoc) (assoc 10 tt) tt)			   tt (subst (cons 1 (rtos (getz p0 p1 p2 pgoc))) (assoc 1 tt) tt)		 )		 (entmake tt)		 (command ".change" "L" "" "p" "c" "6" "")	  )   )); CHHUONG TRINH CON(defun getZ	(p0 p1 p2 p / vta vtb x0 y0 z0 x1 y1 z1 x2 y2 z2 x y A B C)   (setq	  p	  (list (car p) (cadr p))	  vta (mapcar '- p1 p0)	  vtb (mapcar '- p2 p0)   )   (mapcar 'set		   '(x0 y0 z0 x1 y1 z1 x2 y2 z2 x y)		   (append p0 vta vtb p)   )   (setq	  A	(- (* y1 z2) (* y2 z1))	  B	(- (* z1 x2) (* z2 x1))	  C	(- (* x1 y2) (* x2 y1))   )   (/ (- (+ (* A x0) (* B y0) (* C z0)) (+ (* A x) (* B y))) C))

Lisp này mình mót được từ trên diễn đàn Cadviet, hình như của bác Nguyễn Hoành thì phải. Hãy cám ơn bác ấy.                                                                                                                                         

 

 

Nhờ các bạn sửa giúp lisp trên sao cho text nội suy điền vào đúng vị trí nội suy. Thanks!

<<

Hề hề hề,

Gửi bạn cái ni, không biết đã đúng ý bạn chưa??? Lưu ý rằng 3 text mà bạn chọn phải là 3 text có giá...

>>

Hề hề hề,

Gửi bạn cái ni, không biết đã đúng ý bạn chưa??? Lưu ý rằng 3 text mà bạn chọn phải là 3 text có giá trị của cao độ và đặt tại điểm ghi cao độ đó.

(defun c:ns	(/ ss3 pgoc lste tt)
  (princ "\nChon 3 text dau tien: ")
  (setq ss3 (ssget '((0 . "TEXT"))))
  (if (/= (sslength ss3) 3)
  (alert (strcat "\nBan vua chon "
				 (itoa (sslength ss3))
				 " text\nban can phai chon 3 text"
		 )
  )
  (progn
	 (setq
		pgoc (trans (getpoint "\nVao diem noi suy: ") 1 0)
		lste (mapcar 'ssname (list ss3 ss3 ss3) '(0 1 2))
		tt	 (entget (car lste))
		lste (mapcar '(lambda (e)
						 (setq tt (entget e)
							   p  (cdr (assoc 10 tt))
							   gt (atof (cdr (assoc 1 tt)))
						 )
						 (reverse (cons gt (cdr (reverse p))))
					  )
					 lste
			 )
	 )
	 (mapcar 'set '(p0 p1 p2) lste)
	 (setq tt (subst (cons 10 pgoc) (assoc 10 tt) tt)
		   tt (subst (cons 1 (rtos (getz p0 p1 p2 pgoc))) (assoc 1 tt) tt)
	 )
	 (entmake tt)
	 (command ".change" "L" "" "p" "c" "6" "")
  )
  )
)

; CHHUONG TRINH CON
(defun getZ	(p0 p1 p2 p / vta vtb x0 y0 z0 x1 y1 z1 x2 y2 z2 x y A B C)
  (setq
  p	  (list (car p) (cadr p))
  vta (mapcar '- p1 p0)
  vtb (mapcar '- p2 p0)
  )
  (mapcar 'set
	   '(x0 y0 z0 x1 y1 z1 x2 y2 z2 x y)
	   (append p0 vta vtb p)
  )
  (setq
  A	(- (* y1 z2) (* y2 z1))
  B	(- (* z1 x2) (* z2 x1))
  C	(- (* x1 y2) (* x2 y1))
  )
  (/ (- (+ (* A x0) (* B y0) (* C z0)) (+ (* A x) (* B y))) C)
)

 

Lisp này mình mót được từ trên diễn đàn Cadviet, hình như của bác Nguyễn Hoành thì phải. Hãy cám ơn bác ấy.

Như thế này là ổn rồi. Cám ơn bạn!

<<

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

(defun c:tinh()
 (vl-load-com)
 (initget 1 "+ - * /")
 (setq ptinh (getkword "Chon phep tinh <+ - * />: "))

...
>>

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

(defun c:tinh()
 (vl-load-com)
 (initget 1 "+ - * /")
 (setq ptinh (getkword "Chon phep tinh <+ - * />: "))

 (cond ((= ptinh "+")  ;;; cong
 (prompt "\nChon text de cong:")
 (setq ss (ssget '((0 . "TEXT")))
       kqua 0)
 (while (and ss (> (sslength ss) 0))
   (setq kqua (+ kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
   (ssdel ent ss))
 (princ kqua))

((= ptinh "*")  ;;;nhan
 (prompt "\nChon text de nhan:")
 (setq ss (ssget '((0 . "TEXT")))
       kqua 1)
 (while (and ss (> (sslength ss) 0))
   (setq kqua (* kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
   (ssdel ent ss))
 (princ kqua))

((= ptinh "-")  ;;;tru
 (setq sobitru (car (entsel "\nChon so bi tru:"))
       sotru (car (entsel "\nChon so tru:\n"))
       kqua (- (atof (cdr (assoc 1 (entget sobitru))))
	     (atof (cdr (assoc 1 (entget sotru))))))	  
 (princ kqua))

((= ptinh "/")  ;;;chia
 (setq sobichia (car (entsel "\nChon so bi chia:"))
       sochia (car (entsel "\nChon so chia:\n"))
       kqua (/ (atof (cdr (assoc 1 (entget sobichia))))
	     (atof (cdr (assoc 1 (entget sochia))))))	  
 (princ kqua))	
 )  
 (if (not ssle) (setq ssle 0))
 (setq obj (vlax-ename->vla-object (car (entsel "\nChon text de ghi ket qua:")))
	ssle1 (getint (strcat "\nSo so le <" (itoa ssle) ">: ")))
 (if ssle1 (setq ssle ssle1))
 (vla-put-TextString obj (rtos kqua 2 ssle))  
 (princ)	       
)

Sao chọn text k được vậy?

<<

Bạn sử dụng code này xem nhé :

(defun c:pcd(/ cao po)
(setq cao (getdist "\n Nhap chieu cao chu :"))
(while (setq po (getpoint "\n Pick diem :"))
(wtxt (rtos (caddr po) 2 3) po...
>>

Bạn sử dụng code này xem nhé :

(defun c:pcd(/ cao po)
(setq cao (getdist "\n Nhap chieu cao chu :"))
(while (setq po (getpoint "\n Pick diem :"))
(wtxt (rtos (caddr po) 2 3) po 0 cao)
)
(princ)
)
;
(defun wtxt (txt p ang h / sty)
(setq sty (getvar "textstyle"))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) 
(cons 72 0) (cons 73 1) (cons 50 ang) (cons 40 h) (cons 41 1))
)
)

Lisp này của bạn đúng khi pick vào đường đồng mức, còn pick vào khoảng giữa 2 đường đồng mức thì toàn xuất cao độ 0.000

<<

Thử cái này xem thế nào

DBLOCK.LSP

;;Chuong trinh Dinh nghia lai Block va giu nguyen vi tri khi thay doi diem chen
(DEFUN DBLOCK ()
 (setq DCL_ID_BLOCK...
>>

Thử cái này xem thế nào

DBLOCK.LSP

;;Chuong trinh Dinh nghia lai Block va giu nguyen vi tri khi thay doi diem chen
(DEFUN DBLOCK ()
 (setq DCL_ID_BLOCK (load_dialog "BLOCK.DCL"))
 (if (not(new_dialog "BLOCK" DCL_ID_BLOCK)) (exit))
 (start_list "La_BLK")  
 (mapcar 'add_list LiLa)
 (end_list)
 (SETVALUEBLOCK_RE)  
 (action_tile "IsLayer_BLK" "(MODELABLK)")
 (action_tile "info" "(ABOUT)")  
 (action_tile "accept" "(GETVALUEBLOCK_RE) (done_dialog 1)")
 (action_tile "SelectBlock_RE" "(GETVALUEBLOCK_RE) (done_dialog 2)")
 (action_tile "SelectObject_RE" "(GETVALUEBLOCK_RE) (done_dialog 3)")
 (action_tile "SelectPoint_RE" "(GETVALUEBLOCK_RE) (done_dialog 4)")
 (action_tile "apply" "(GETVALUEBLOCK_RE) (done_dialog 5)")
 (setq RES_BLK (start_dialog))  
 (if (= RES_BLK 2)
(progn
  (SELECTBLOCK_RE)
  (DBLOCK)
)  
 )
 (if (= RES_BLK 3)
(progn
  (setq ssObj (SELECTOBJ_RE))
  (DBLOCK)
)  
 )
 (if (= RES_BLK 4)
(progn
  (setq reblocktoado_RE (getpoint "Chon diem chen cua BLOCK: "))
  (DBLOCK)
)  
 )
 (if (= RES_BLK 5)
(progn
  (RE_FIX_BLOCK)
  (DBLOCK)
)  
 )
 (unload_dialog DCL_ID_BLOCK) 
)
(DEFUN C:DB()
 (setvar "CMDECHO" 0)
 (BLOCK_INIT)
 (DBLOCK)
 (setvar "CMDECHO" 1)
)
(DEFUN BLOCK_INIT()
 (CREALILA)
 (if (Null blockname_RE)
(setq blockname_RE "Temp_Block")
 )
 (setq blocktoado_RE (List 0 0))
 (setq reblocktoado_RE Nil)
 (if (Null fixPosBlock_RE)
(setq fixPosBlock_RE "1")
 )
 (setq ssObj Nil)
 (setq gocBlock_RE "0")
 (setq xscBlock_RE "1")
 (setq yscBlock_RE "1")
 (setq IsRedefine 0)
 (if (Null IsLayer_BLK)
(setq IsLayer_BLK "0")
 )
 (setq P0_BLK (List 0 0))
 (if (Null idlablock)
(setq idlablock "0")
 )  
)
(DEFUN SETVALUEBLOCK_RE()
 (set_tile "Blockname_RE" blockname_RE)
 (set_tile "fixPosBlock_RE" fixPosBlock_RE)
 (set_tile "IsLayer_BLK" IsLayer_BLK)
 (set_tile "XOAY_BLK" gocBlock_RE)
 (set_tile "SCX_BLK" xscBlock_RE)
 (set_tile "SCY_BLK" yscBlock_RE)
 (set_tile "TDXY_BLK" (strcat (rtos (car blocktoado_RE) 2 1)" : " (rtos (cadr blocktoado_RE) 2 1)))
 (if (= IsLayer_BLK "1")
(mode_tile "La_BLK" 0)
(mode_tile "La_BLK" 1)
 )
 (set_tile "La_BLK" idlablock)
)
(DEFUN MODELABLK()
 (setq IsLayer_BLK (get_tile "IsLayer_BLK"))
 (if (= IsLayer_BLK "1")
(mode_tile "La_BLK" 0)
(mode_tile "La_BLK" 1)
 )
)  
(DEFUN GETVALUEBLOCK_RE()
 (setq IsLayer_BLK (get_tile "IsLayer_BLK"))
 (setq blockname_RE (get_tile "Blockname_RE"))
 (setq fixPosBlock_RE (get_tile "fixPosBlock_RE"))
 (setq idlablock (get_tile "La_BLK"))
)  
(DEFUN SELECTBLOCK_RE(/ ss)
 (setq ss Nil)
 (setq ss (ssget))
 (setq dt (ssname ss 0))  
 (if (= (cdr (assoc 0 (entget dt))) "INSERT")
(progn
  (setq blockname_RE (TENDOITUONG dt))  
  (setq blocktoado_RE (TOADOXY dt))	  
  (setq gocBlock_RE (angtos (GOCXOAY dt)))	  
  (setq xscBlock_RE (rtos (X_SCALE dt) 2 2))
  (setq yscBlock_RE (rtos (Y_SCALE dt) 2 2))
  (if (OR (/= (atof gocBlock_RE) 0) (/= xscBlock_RE yscBlock_RE) (/= xscBlock_RE "1.00"))
	(progn
	  (alert "Doi tuong nay khong the dinh nghia lai. \nHay chon mot doi tuong khac co goc xoay bang 0 va X_Scale = Y_Scale = 1")
	  (setq IsRedefine 0)
	)
	(progn		  
	  (command "EXPLODE" dt)
	  (setq IsRedefine 1)
	)  
  )
)
(alert "Doi tuong vua chon khong phai la Block")
 )
)  
(DEFUN SELECTOBJ_RE(/ ss)
 (setq ss Nil)
 (while (= ss Nil)
(setq ss (ssget))
 )  
 ss
)
(DEFUN TENDOITUONG (obj / name)
 (if (/= (cdr (assoc 0 (entget obj))) "INSERT")
(setq name (cdr (assoc 0 (entget obj))))
(setq name (cdr (assoc 2 (entget obj))))
 )
 name  
)
(DEFUN TOADOXY (obj / td)
 (setq td (cdr (assoc 10 (entget obj))))
 td
)
(DEFUN RE_FIX_BLOCK(/ kc goc ssBlock)
 (if (AND (/= reblocktoado_RE Nil) (/= blocktoado_RE Nil)(= IsRedefine 1))
(progn
  (command "-BLOCK" blockname_RE "Y" reblocktoado_RE ssObj "")
  (command "-INSERT" blockname_RE blocktoado_RE "1" "1" "0")
  (setq dt (entlast))
  (command "SCALE" dt "" reblocktoado_RE (atof xscBlock_RE))
  (setq tempGoc (angle blocktoado_RE reblocktoado_RE))
  (setq layerblock (nth (atoi idlablock) LiLa))
  (setq IsRedefine 0)
  (if (= fixPosBlock_RE "1")
	(progn	  
	  (setq disBLK (distance blocktoado_RE reblocktoado_RE))	  
	  (setq ssBlock (ssget "X" '((0 . "INSERT"))))	  
	  (setq n (sslength ssBlock))	  
	  (setq i 0)
	  (while (< i n)		
	(setq dt (ssname ssBlock i))
	(if (= (TENDOITUONG dt) blockname_RE)
	  (progn
	(if (= IsLayer_BLK 1)
	  (progn
		(if (= (LAYERNAME dt) layerblock)
		  (progn
		(setq xscdtBLK (X_SCALE dt))
			(if (< xscdtBLK 0)
			  (setq gocdtBLK (+ (GOCXOAY dt) (- Pi tempGoc)))
			  (setq gocdtBLK (+ (GOCXOAY dt) tempGoc))
			)
			(setq P1 (polar P0_BLK gocdtBLK (* disBLK xscdtBLK)))		
				(command "MOVE" dt "" P0_BLK P1)
		  )	
		)  
	  )
	  (progn
		(setq xscdtBLK (X_SCALE dt))
		(if (< xscdtBLK 0)
		  (setq gocdtBLK (+ (GOCXOAY dt) (- Pi tempGoc)))
		  (setq gocdtBLK (+ (GOCXOAY dt) tempGoc))
		)		 
		(setq P1 (polar P0_BLK gocdtBLK (abs (* disBLK xscdtBLK))))		
			(command "MOVE" dt "" P0_BLK P1)		
	  )  
	)
	  )
	)  
	(setq i (+ i 1))
	  )	
	)  
  )
)
(progn
  (if (= blocktoado_RE Nil)
(alert "Chua chon BLOCK can dinh nghia lai")
  )
  (if (= reblocktoado_RE Nil)
(alert "Chua chon diem chen moi cho BLOCK can dinh nghia")
  )
)
 )  
)
(DEFUN CREALILA (/ NL)
 (setq LiLa (List))
 (setq NL (tblnext "LAYER" T))  
 (while NL	
(setq LiLa (append LiLa (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "LAYER"))
 )
 (setq LiLa (Acad_strlsort LiLa))
)
(DEFUN GOCXOAY (obj / goc)
 (setq goc (cdr (assoc 50 (entget obj))))
 goc
)
(DEFUN X_SCALE (obj / sc)
 (setq sc (cdr (assoc 41 (entget obj))))
 sc
)
(DEFUN Y_SCALE (obj / sc)
 (setq sc (cdr (assoc 42 (entget obj))))
 sc
)
(DEFUN LAYERNAME (obj / laname)
 (setq laname (cdr (assoc 8 (entget obj))))
 laname
)
(DEFUN ABOUT(/ DCL_ID_ABOUT)
 (setq DCL_ID_ABOUT (load_dialog "DCLBLOCK.DCL"))
 (if (not(new_dialog "ABOUT" DCL_ID_ABOUT))(exit))  
 (start_list "aboutme")
 (add_list " ")  
 (add_list "  VO KIEN CUONG - Bachelor of IT")
 (add_list "  =====================================================")
 (add_list "  Email : vkcuong_23@yahoo.com")
 (add_list "  Mobile: 0983616182 - 0977352125")
 (add_list "  CAD developer (LISP, DCL, VBA for AutoCad, ObjectARX...)")
 (add_list "  Web developer (ASP, ASP.Net, Java, XML, Script, C#.Net...)")
 (add_list "  ")
 (end_list)
 (start_dialog)
 (unload_dialog DCL_ID_ABOUT)
)

BLOCK.DCL

//Chuong trinh Dinh nghia lai Block va giu nguyen vi tri khi thay doi diem chen
BLOCK:dialog	{
label="REDEFINE BLOCK";
:row	{
	:edit_box{
		label="Ten Block";
		key="Blockname_RE";
		edit_width=20;
		}
	:spacer	{
		width=15;
		}	
	}
	spacer_1;
:row	{
	:boxed_column{
		label= "Thong tin Bolck";
		:button	{
			label="Chon Block";
			key="SelectBlock_RE";
			}
		:edit_box{
			label="Toa do:";
			key="TDXY_BLK";
			edit_width=15;
			}
		:edit_box{
			label="Goc xoay:";
			key="XOAY_BLK";
			edit_width=12;
			}
		:edit_box{
			label="Ty le X:";
			key="SCX_BLK";
			edit_width=12;
			}
		:edit_box{
			label="Ty le Y:";
			key="SCY_BLK";
			edit_width=12;
			}	
		}
	:boxed_column{
		label="Dinh nghia lai Bolck";			
		:button	{
			label="Chon doi tuong";
			key="SelectObject_RE";
			}
		:button	{
			label="Chon diem dat";
			key="SelectPoint_RE";
			}
		:toggle {
			label="Block trong Layer";
			key="IsLayer_BLK";
			}
		:popup_list{
			key="La_BLK";
			edit_width=25;
			}
		:toggle	{
			label="Giu vi tri Block";
			key="fixPosBlock_RE";
			value="1";
			}			
		}
	}	
spacer_1;
:row	{		
	:button	{
		label="Apply";
		key="apply";
		}
	ok_cancel;
	:button	{
		label="Info..";
		key="info";
		}
	}
}

 

vndesperados khi chay chuong trinh tôi gặp lỗi sau:

Command: (load"dblock")

ABOUT

 

Command: db ; error: quit / exit abort

 

mong chỉ dẫn. Thanks

<<

@Bác Hạ: Thử dùng code này xem có được không??? (Dùng biện pháp nổ).

(defun c:tt (/ ble bln els i lst ss typ)

(if (setq ss (ssget '((0 . "INSERT"))))

(progn (repeat (setq i (sslength ss))

(setq ble (ssname ss (setq i (1- i)))

bln (cdr (assoc 2 (entget ble)))

lst nil)

(foreach e (mapcar 'vlax-vla-object->ename

(vlax-safearray->list (vlax-variant-value (vla-Explode...

@Bác Hạ: Thử dùng code này xem có được không??? (Dùng biện pháp nổ).

(defun c:tt (/ ble bln els i lst ss typ)

(if (setq ss (ssget '((0 . "INSERT"))))

(progn (repeat (setq i (sslength ss))

(setq ble (ssname ss (setq i (1- i)))

bln (cdr (assoc 2 (entget ble)))

lst nil)

(foreach e (mapcar 'vlax-vla-object->ename

(vlax-safearray->list (vlax-variant-value (vla-Explode (vlax-ename->vla-object ble)))))

(setq els (entget e)

typ (cdr (assoc 0 els)))

(cond ((= "LINE" typ)

(setq lst (cons (list typ (cdr (assoc 10 els)) (cdr (assoc 11 els))) lst)))

((= "LWPOLYLINE" typ)

(setq lst (cons (list typ (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) els))) lst)))

((member typ '("POINT" "TEXT")) (setq lst (cons (list typ (cdr (assoc 10 els))) lst))))

(entdel e))

(mapcar 'print (cons bln lst)))

(textscr)))

(princ))

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)
Kết quả trả về là 1 danh sách:
* Đối với chuột: (code point)
- Khi rê chuột: (5 pt) => pt là điểm.
- Khi nhấn phím trái chuột: (3 pt)
- Khi nhấn phím phải: (25 code)
- Pick chọn vào các menu, button... ra nhiều kết quả khác (có code để test ở dưới).

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)
Kết quả trả về là 1 danh sách:
* Đối với chuột: (code point)
- Khi rê chuột: (5 pt) => pt là điểm.
- Khi nhấn phím trái chuột: (3 pt)
- Khi nhấn phím phải: (25 code)
- Pick chọn vào các menu, button... ra nhiều kết quả khác (có code để test ở dưới).
* Đối với bàn phím: (2 key) => trong đó key là mã ký tự bàn phím.
* Shift + Phím phải chuột: => '(11 1000)
* Thiết bị khác chưa dùng nên chưa biết (ví dụ bảng vẽ...)
2. Phân tích vòng lặp của bạn:
- Vòng while chỉ tiếp tục khi phần tử đầu của danh sách trả về là 5 hoặc 2 (tức là khi rê chuột và nhấn bàn phím)
- Khi nhấn phím trái (pick point) khi đó (car ptgr) = 3
- Khi gõ ký tự từ bàn phím: (car ptgr) = 2, (cadr ptgr) sẽ là mã ký tự chứ không phải point => Lỗi.
3. Đoạn code sửa lại vòng lặp (Phím phải hoặc Enter đều kết thúc lệnh)
*** Bổ sung thêm nhập từ bàn phím:
- Phím h, hoặc H: Chiều cao chữ sẽ tăng 1.05 lần...
- Phím s, hoặc S: Chiều cao chữ sẽ giảm 0.95 lần...

;; Them
(setq tmp t)
(setq text (vlax-ename->vla-object (MakeText Pt2A (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))
;; Sua
(while (and tmp (setq ptgr (grread 't 12 0)))
(cond ;; Re chuot - Dragging
((eq (car ptgr) 5)
(setq PntPick (trans (cadr ptgr) 1 0))
(if text
(progn (if (= (CheckPntbetween2Pnt Pt1A Pt2A PntPick) 1)
(setq Caodo3 (NSG2D Pt1A Pt2A PntPick))
(setq Caodo3 (NSN2D Pt1A Pt2A PntPick)))
(vlax-put text 'InsertionPoint (mapcar '+ PntPick '(0.1 0.1 0.0)))
(vlax-put text 'TextString (rtos Caodo3 2 3))
(redraw)
(grdraw Pt1A PntPick 7 1)
(grdraw Pt2A PntPick 7 1))
(setq text (vlax-ename->vla-object
(MakeText PntPick (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))))
;; Tang chieu cao chu: Nhan Phim H=72;h=104
((or (equal ptgr '(2 72)) (equal ptgr '(2 104)))
(setq Caochu (* Caochu 1.05))
(vlax-put text 'Height caochu))
;; Giam chieu cao chu: Nhan Phim S=72;s=104
((or (equal ptgr '(2 83)) (equal ptgr '(2 115)))
(setq Caochu (* Caochu 0.95))
(vlax-put text 'Height caochu))
;; Phim trai chuot - Picked point
((eq (car ptgr) 3) (setq text nil) (redraw))
;; Phim phai chuot hoac Enter - Right click or Enter
((or (eq (car ptgr) 25) (equal ptgr '(2 13))) (setq tmp nil) (and text (vla-delete text)))))

(defun c:tt (/ grr tmp)
;; Test Grread - QuocManh04tt.
(setq tmp t)
(while (and tmp (setq grr (grread 't 15 0)))
(cond ((eq (car grr) 5) (princ "\nDI CHUOT, KET QUA grread: ") (princ grr))
((eq (car grr) 3) (princ "\nPHIM TRAI CHUOT, KET QUA grread: ") (princ grr))
((eq (car grr) 25) (princ "\nPHIM PHAI CHUOT, KET QUA grread: ") (princ grr))
((equal grr '(11 1000)) (princ "\nShift+Phim phai chuot, KET QUA grread: ") (princ grr))
((eq (car grr) 2)
(princ (strcat "\nBAN DA NHAN PHIM  KET QUA grread: "))
(princ grr))
(t (princ "\n") (princ grr))))
(princ))

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)

Kết...

>>

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)

Kết quả trả về là 1 danh sách:

* Đối với chuột: (code point)

- Khi rê chuột: (5 pt) => pt là điểm.

- Khi nhấn phím trái chuột: (3 pt)

- Khi nhấn phím phải: (25 code)

- Pick chọn vào các menu, button... ra nhiều kết quả khác (có code để test ở dưới).

* Đối với bàn phím: (2 key) => trong đó key là mã ký tự bàn phím.

* Shift + Phím phải chuột: => '(11 1000)

* Thiết bị khác chưa dùng nên chưa biết (ví dụ bảng vẽ...)

2. Phân tích vòng lặp của bạn:

- Vòng while chỉ tiếp tục khi phần tử đầu của danh sách trả về là 5 hoặc 2 (tức là khi rê chuột và nhấn bàn phím)

- Khi nhấn phím trái (pick point) khi đó (car ptgr) = 3

- Khi gõ ký tự từ bàn phím: (car ptgr) = 2, (cadr ptgr) sẽ là mã ký tự chứ không phải point => Lỗi.

3. Đoạn code sửa lại vòng lặp (Phím phải hoặc Enter đều kết thúc lệnh)

*** Bổ sung thêm nhập từ bàn phím:

- Phím h, hoặc H: Chiều cao chữ sẽ tăng 1.05 lần...

- Phím s, hoặc S: Chiều cao chữ sẽ giảm 0.95 lần...

;; Them

(setq tmp t)

(setq text (vlax-ename->vla-object (MakeText Pt2A (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))

;; Sua

(while (and tmp (setq ptgr (grread 't 12 0)))

(cond ;; Re chuot - Dragging

((eq (car ptgr) 5)

(setq PntPick (trans (cadr ptgr) 1 0))

(if text

(progn (if (= (CheckPntbetween2Pnt Pt1A Pt2A PntPick) 1)

(setq Caodo3 (NSG2D Pt1A Pt2A PntPick))

(setq Caodo3 (NSN2D Pt1A Pt2A PntPick)))

(vlax-put text 'InsertionPoint (mapcar '+ PntPick '(0.1 0.1 0.0)))

(vlax-put text 'TextString (rtos Caodo3 2 3))

(redraw)

(grdraw Pt1A PntPick 7 1)

(grdraw Pt2A PntPick 7 1))

(setq text (vlax-ename->vla-object

(MakeText PntPick (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))))

;; Tang chieu cao chu: Nhan Phim H=72;h=104

((or (equal ptgr '(2 72)) (equal ptgr '(2 104)))

(setq Caochu (* Caochu 1.05))

(vlax-put text 'Height caochu))

;; Giam chieu cao chu: Nhan Phim S=72;s=104

((or (equal ptgr '(2 83)) (equal ptgr '(2 115)))

(setq Caochu (* Caochu 0.95))

(vlax-put text 'Height caochu))

;; Phim trai chuot - Picked point

((eq (car ptgr) 3) (setq text nil) (redraw))

;; Phim phai chuot hoac Enter - Right click or Enter

((or (eq (car ptgr) 25) (equal ptgr '(2 13))) (setq tmp nil) (and text (vla-delete text)))))

4. Còn đây là code để test grread:

- Sau khi gọi lệnh => rê chuột, phím trái, phím phải để xem kết quả dưới dòng command.

- Thả chuột, gõ ký tự từ bàn phím và xem kết quả.

(defun c:tt (/ grr tmp)

;; Test Grread - QuocManh04tt.

(setq tmp t)

(while (and tmp (setq grr (grread 't 15 0)))

(cond ((eq (car grr) 5) (princ "\nDI CHUOT, KET QUA grread: ") (princ grr))

((eq (car grr) 3) (princ "\nPHIM TRAI CHUOT, KET QUA grread: ") (princ grr))

((eq (car grr) 25) (princ "\nPHIM PHAI CHUOT, KET QUA grread: ") (princ grr))

((equal grr '(11 1000)) (princ "\nShift+Phim phai chuot, KET QUA grread: ") (princ grr))

((eq (car grr) 2)

(princ (strcat "\nBAN DA NHAN PHIM KET QUA grread: "))

(princ grr))

(t (princ "\n") (princ grr))))

(princ))

Không biết gì nói lời cảm ơn bác Quocmanh04tt!

Lần nào cũng được bác tư vấn và cho lời giải thật tuyệt.

Lần trước em hay được bác Doan Van Ha giúp và bác ấy cũng rất tuyệt. Nhiệt tình và tài giỏi. Em cũng đang mò mẫm từng bước một thôi.

Cũng nhân tiện đây, bác Quocmanh có thêm được cái bắt điểm nữa không ạ?

Nếu nó không dễ thì thôi ạ! Em dùng cái này cũng rất tuyệt vời rồi.

<<

Download lisp

Filename: 414427_tt.lsp

Chào các bác!

Em mày mò và vọc được 1 lisp của Lee_Mac về việc đồng bộ hóa bán kính đường tròn trong nhóm đường tròn được lựa chọn.

Tuy nhiên, với số lượng ít thì chương trình có thể chạy được (em Test thử với 170 đường tròn thì OK) nhưng khi con số lớn hơn 1 chút (VD: 300 đường tròn) thì Cad đơ và thoát. Rất mong được các bác chỉ giáo để gỡ rối ạ!

Em cảm...

Chào các bác!

Em mày mò và vọc được 1 lisp của Lee_Mac về việc đồng bộ hóa bán kính đường tròn trong nhóm đường tròn được lựa chọn.

Tuy nhiên, với số lượng ít thì chương trình có thể chạy được (em Test thử với 170 đường tròn thì OK) nhưng khi con số lớn hơn 1 chút (VD: 300 đường tròn) thì Cad đơ và thoát. Rất mong được các bác chỉ giáo để gỡ rối ạ!

Em cảm ơn!

(defun c:radlink (/ idx lst sel)
  (foreach rtr (cdar (vlr-reactors :vlr-object-reactor))
    (if	(= "radlink" (vlr-data rtr))
      (vlr-remove rtr)
    )
  )
  
  (if (setq sel (ssget "_:L" '((0 . "CIRCLE"))))
    (progn
      (repeat (setq idx (sslength sel))
	(setq lst (cons	(vlax-ename->vla-object
			  (ssname sel (setq idx (1- idx)))
			)
			lst
		  )
	)
      )
      (radlink-callback
	(car lst)
	(vlr-object-reactor
	  lst
	  "radlink"
	  '((:vlr-modified . radlink-callback))
	)
	nil
      )
    )
  )
  (princ)
)
(defun radlink-updateradius (obj rad)
    (if	(and (vlax-read-enabled-p obj)
	     (not (equal (vla-get-radius obj) rad 1e-8))
	     (vlax-write-enabled-p obj)
	)
      (vla-put-radius obj rad)
    )
  )
(defun radlink-callback	(own rtr arg / rad)
  
  (if (and (vlax-read-enabled-p own) (setq rad (vla-get-radius own)))
    (foreach obj (vlr-owners rtr) (radlink-updateradius obj rad))
  )
)

 

Bạn thử dùng xem sao nếu tốt thì Like nhé :

(defun c:sci (/ ss tile i en obj ins) (vl-load-com)
(princ...
>>

 

Bạn thử dùng xem sao nếu tốt thì Like nhé :

(defun c:sci (/ ss tile i en obj ins) (vl-load-com)
(princ "\nChon cac Block :") 
(setq ss (ssget '((0 . "INSERT"))) 
tile (getreal "\nChon tile Scale:")) 
(setq i 0) 
(while (< i (sslength ss)) (setq en (ssname ss i) 
obj (vlax-ename->vla-object en)
ins (vla-get-InsertionPoint obj)) 
(vla-ScaleEntity obj ins tile) (setq i (1+ i)) ) 
(princ)
)

chính xác những gì mình cần, thank you very much (y)

<<

Download lisp

Filename: 408128_sci.lsp

Bạn thử dùng xem sao nếu tốt thì Like nhé :

(defun c:sci (/ ss tile i en obj ins) (vl-load-com)
(princ "\nChon...
>>

Bạn thử dùng xem sao nếu tốt thì Like nhé :

(defun c:sci (/ ss tile i en obj ins) (vl-load-com)
(princ "\nChon cac Block :") 
(setq ss (ssget '((0 . "INSERT"))) 
tile (getreal "\nChon tile Scale:")) 
(setq i 0) 
(while (< i (sslength ss)) (setq en (ssname ss i) 
obj (vlax-ename->vla-object en)
ins (vla-get-InsertionPoint obj)) 
(vla-ScaleEntity obj ins tile) (setq i (1+ i)) ) 
(princ)
)

Tu lsp này ban có the phat huy xoay text trong block luon di ban. Thank ban truoc

<<

Đây là lisp bạn cần:

;;;-------------------------------------------------------------
(defun c:erC (/ sc cur p0 P1 L1 d L n ssgDEL glength)
 (princ "\nFree lisp from...
>>

Đây là lisp bạn cần:

;;;-------------------------------------------------------------
(defun c:erC (/ sc cur p0 P1 L1 d L n ssgDEL glength)
 (princ "\nFree lisp from www.cadviet.com")
 (command "undo" "be")
 (setvar "osmode" 0)
 (setq	sc	2009
cur	(car (entsel "\nchon duong: "))
glength	(lambda (e) (command ".lengthen" e "") (getvar "perimeter"))
d	(/ (glength cur) sc)
l1	0.0
p0	(vlax-curve-getStartPoint cur)
L	(list p0)
 )
 (redraw cur 4)
 (repeat sc
   (setq
     l1 (+ l1 d)
     p1 (vlax-curve-getPointAtDist cur l1)

   )
   (setq L (append L (List p1)))
 )
 (setq ssgDEL (ssget "WP" L))
 (setq n 0)
 (repeat (sslength ssgDEL)
   (entdel (ssname ssgDEL n))
   (setq n (1+ n))
 )
 (command "undo" "end")
 (princ "\nChuc cac ban may man va thanh cong - Thiep 0918841230")
 (princ)
)
(vl-load-com)

Không phải xóa thủ công nữa nhé.

Bác Thiệp à, lisp của bác tuyệt vời quá, e thanks bác nhiều nhé! tiện đây bác giúp e lisp xoá các đối tượng nằm ngoài vùng kín với đưọc không ạ?

<<

Nếu muốn như vậy thì bạn phải sử dụng Lisp Scale theo 1 phương X trước rồi tiếp theo đó bạn scale 1 chiều theo phương Y sau.

Như vậy thì mới đạt được kết quả mong...

>>

Nếu muốn như vậy thì bạn phải sử dụng Lisp Scale theo 1 phương X trước rồi tiếp theo đó bạn scale 1 chiều theo phương Y sau.

Như vậy thì mới đạt được kết quả mong muốn .

Đây là lệnh XSC : Scale theo 1 phương :

;XSCALE Scale the mot chieu lenhtat :XSC
(DEFUN EXCUTE()
 (setq oldvalue (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (princ "Chon doi tuong can scale: ")
 (setq ss (ssget))
 (setq P0 (getpoint "\nChon diem goc: "))
 (initget 1 "X Y X S")
 (setq C (getkword "\nScale theo ? :"))
 (setq hs (getreal "Cho biet he so scale: "))
 (DELBLOCK "vkc_temp")
 (CREATEBLOCK ss P0)  
 (Command "-Insert" "vkc_temp" C hs P0 "")   
 (setq dt (entlast))
 (Command "Explode" dt)
 (setvar "CMDECHO" oldvalue)
 (princ)
)
(DEFUN CREATEBLOCK(ss P)
 (command "-Block" "vkc_temp" P ss "")
)

(DEFUN DELBLOCK (bname)
 (if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")	
 )
)
(DEFUN IsExistBlock(bname / kq)
 (setq kq Nil)
 (setq n (length LiBlk))
 (setq i 0)
 (while (< i n)
(if (= bname (nth i LiBlk))
  (progn
(setq i n)
(setq kq T)
  )	
)
(setq i (1+ i))
 )
 kq
)
(DEFUN CREALIBLK (/ NL)
 (setq LiBlk (List))
 (setq NL (tblnext "BLOCK" T))  
 (while NL	
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK"))
 )
 (setq LiBlk (Acad_strlsort LiBlk))
)
(DEFUN C:XSCALE()
 (CREALIBLK)
 (EXCUTE)
)
(DEFUN C:XSC()
 (CREALIBLK)
 (EXCUTE)
)

Down file đó về rùi bỏ nó vào đâu vậy bạn

<<

Lệnh UDT (Update diện tích) dưới đây sẽ làm điều bạn muốn:

(defun c:udt(/ ss tong ham tmp tt)
 (setq
   ss (ssget '((-4 . "<OR")(0 . "LWPOLYLINE")(0 ....
>>

Lệnh UDT (Update diện tích) dưới đây sẽ làm điều bạn muốn:

(defun c:udt(/ ss tong ham tmp tt)
 (setq
   ss (ssget '((-4 . "<OR")(0 . "LWPOLYLINE")(0 . "REGION")(0 . "CIRCLE")(0 . "ARC")(-4 . "OR>")))	
   tong 0.0
   ham (lambda (x) (command ".area" "o" x) (setq tong (+ tong (getvar "area"))))
   tmp (mapcar 'ham (ss2ent ss))  
   tt (entget (car (entsel "\nChon text ket qua: ")))
   tong (vl-string-right-trim "." (vl-string-right-trim "0" (rtos tong)))
 )
 (entmod (subst (cons 1 tong) (assoc 1 tt) tt))
)

(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)
)
(princ "\nUpdate Area - free lisp from cadviet.com")
(princ "\nUse UDT command to start!")
(vl-load-com)

 

Cám ơn bác Hoanh nhé, yêu cầu của em đã được đáp ứng. Diễn đàn Cadviet rất có ích cho những cư dân dùng AutoCad. Năm mới, em chúc bác mạnh khỏe, thành đạt và hạnh phúc trong cuộc sống.

<<

Lệnh UDT (Update diện tích) dưới đây sẽ làm điều bạn muốn:

(defun c:udt(/ ss tong ham tmp tt)
 (setq
   ss (ssget '((-4 . "")))	
   tong 0.0
   ham (lambda...
>>

Lệnh UDT (Update diện tích) dưới đây sẽ làm điều bạn muốn:

(defun c:udt(/ ss tong ham tmp tt)
 (setq
   ss (ssget '((-4 . "")))	
   tong 0.0
   ham (lambda (x) (command ".area" "o" x) (setq tong (+ tong (getvar "area"))))
   tmp (mapcar 'ham (ss2ent ss))  
   tt (entget (car (entsel "\nChon text ket qua: ")))
   tong (vl-string-right-trim "." (vl-string-right-trim "0" (rtos tong)))
 )
 (entmod (subst (cons 1 tong) (assoc 1 tt) tt))
)

(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)
)
(princ "\nUpdate Area - free lisp from cadviet.com")
(princ "\nUse UDT command to start!")
(vl-load-com)

 

Anh cho em hỏi nếu tỉ lệ bản vẽ không phải là 1/1 thì sửa thế nào để giá trị diện tích đo được gán vào text được đúng ( VD: bản vẽ dùng đơn vị là mm nhưng cần thể hiện kết quả diện tích là m2 chứ không phải mm2 ?Phải chỉnh lại lisp này chổ nào ? Em không biết nhiều về lisp. :cheers:

<<

Bạn nào test giùm tôi 2 lệnh lisp đơn giản sau đều có  dùng grread.

- HA1: di chuột không xuất hiện mũi tên ở điểm đi >> mong muốn

- HA2: di chuột có xuất hiện mũi tên nhấp nháy rất khó chịu >> không mong muốn.

Sau khi lấy được pt nếu thao tác sau đó càng nặng nề thì mũi tên càng nháy khủng.

Chắc mũi tên phụ thuộc 1 biến hệ thống nào nữa...

Bạn nào test giùm tôi 2 lệnh lisp đơn giản sau đều có  dùng grread.

- HA1: di chuột không xuất hiện mũi tên ở điểm đi >> mong muốn

- HA2: di chuột có xuất hiện mũi tên nhấp nháy rất khó chịu >> không mong muốn.

Sau khi lấy được pt nếu thao tác sau đó càng nặng nề thì mũi tên càng nháy khủng.

Chắc mũi tên phụ thuộc 1 biến hệ thống nào nữa ngoài tham số Curtype trong hàm grread

(GRREAD ])

(defun C:HA1()
  (while (setq grr (grread T 4 0) code (car grr) pt (cadr grr))))
 (defun C:HA2()
  (command "point" '(0 0))
  (while (setq grr (grread T 4 0) code (car grr) pt (cadr grr))
   (entdel (entlast))
   (command "point" pt)))

Em hiểu đường 3d xét về bản chất nó vẫn là mặt 3D vì khi dùng lệnh Copy face nó chấp nhận thực hiện lệnh.

Em lăn tăn về cách gọi vì thế em chỉ dám nói là: Các điểm của Polyline có cao độ Z khác nhau rất khó gọi nó là hình 3D.

Biểu tượng có hình lò xo là lệnh...

Em hiểu đường 3d xét về bản chất nó vẫn là mặt 3D vì khi dùng lệnh Copy face nó chấp nhận thực hiện lệnh.

Em lăn tăn về cách gọi vì thế em chỉ dám nói là: Các điểm của Polyline có cao độ Z khác nhau rất khó gọi nó là hình 3D.

Biểu tượng có hình lò xo là lệnh Helix: vẽ xong đường dẫn xoắn ốc như hình vẽ > vẽ tiếp tiết diện của lò xo > gõ tiếp lệnh SWEEP để tạo lò xo có đường kính.

Lisp này sẽ giúp bạn : (theo giống ý của Xuantran)

1. Chọn các 3DPOLY

2 -> Lisp sẽ convert 3D polyline to Polyline cho bạn

Đây :

(defun c:c3d2d( / ssg ss  from to cur)(setq ssg (ssget '((0 . "POLYLINE"))) i 0 ss (ssadd))(while (< i (sslength ssg))(setq frome (entlast))(setq e (ssname ssg i))(command "explode" e "") (setq toe (entlast)) (setq cur frome)(while (not (eq cur toe)) (setqcur (entnext cur)ss (ssadd cur ss)))(command "PEDIT" "m" ss "" "Y" "j" "0" "")(setq i (1+ i)))(princ))

Nguồn: Giúp đỡ về lệnh Convert 3D polyline to Polyline http://www.cadviet.c...showtopic=14133

Lệnh INVIS & VIS.

;; ============================================================	;;
;;                                                              ;;
;;  INVIS.LSP - Makes...
>>

Lệnh INVIS & VIS.

;; ============================================================	;;
;;                                                              ;;
;;  INVIS.LSP - Makes objects temporarily invisible and  	;;
;;	        returns visibility.		 		;;
;;                                                          	;;
;; ============================================================	;;
;;                                                            	;;
;;  Command(s) to call: INVIS                         		;;
;;                                                            	;;
;; ============================================================	;;
;;                                                             	;;
;;  THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD	;;
;;  ON ANY MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS	;;
;;  PROGRAM OR PARTS OF IT ABSOLUTELY FREE.                 	;;
;;                                                              ;;
;;  THIS PROGRAM PROVIDES THIS PROGRAM 'AS IS' WITH ALL FAULTS	;;
;;  AND SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF		;;
;;  MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.            ;;
;;                                                            	;;
;; ============================================================	;;
;;                                                              ;;
;;  V1.1, 11th Apr 2005, Riga, Latvia                   	;;
;;  © Aleksandr Smirnov (ASMI)                          	;;
;;  For AutoCAD 2000 - 2008 (isn't tested in a next versions)	;;
;;                                                              ;;
;;                             http://www.asmitools.com   	;;
;;                                                            	;;
;; ============================================================ ;;

(defun c:invis(/ errCount wMode objSet actDoc *error*)

 (vl-load-com)

 (defun put_Visible_Prop(Object Flag)
   (if
     (vl-catch-all-error-p
(vl-catch-all-apply
  'vla-put-visible (list Object Flag)))
         (setq errCount(1+ errCount))
   ); end if
 (princ)
 ); end of put_Visible_Prop

 (defun Set_to_List(SelSet)
   (mapcar 'vlax-ename->vla-object
                   (vl-remove-if 'listp
                    (mapcar 'cadr(ssnamex SelSet))))
 ); end of Set_to_List

 (defun errMsg()
   (if(/= 0 errCount)
 (princ(strcat ", " (itoa errCount)
	" were on locked layer."))
     "."
 ); end if
   ); end of errMsg

(setq actDoc(vla-get-ActiveDocument
      (vlax-get-Acad-object))
     errCount 0); end setq
 (vla-StartUndoMark actDoc)
(initget "Visible Invisible" 1)
 (setq wMode
   (getkword "\nMake objects : "))
 (if(and
      (= wMode "Visible")
      (setq objSet(ssget "_X" '((60 . 1))))
      ); end and
   (progn
     (setq objSet(Set_to_List objSet))
  (mapcar
   '(lambda(x)(put_Visible_Prop x :vlax-true))objSet)
   (princ
     (strcat "\n<< "
      (itoa(-(length objSet)errCount))
	   " now visible" (errMsg) " >>"))
     ); end progn
   (progn
     (if(not(setq objSet(ssget "_I")))
(setq objSet(ssget))
); end if
     (if objSet
(progn
  (setq objSet(Set_to_List objSet))
 (mapcar
   '(lambda(x)(put_Visible_Prop x :vlax-false))objSet)
   (princ
     (strcat "\n<< "
      (itoa(-(length objSet)errCount))
	   " now invisible" (errMsg) " >>"))
  ; end if
 ); end progn
); end if
      ); end progn
     ); end if
 (vla-EndUndoMark actDoc)
(princ)
); end of c:invis

(princ "\n*** Type INVIS to make objects invisible/visible. *** ")

Hi!

Thanks U bạn nhìu, lâu ni hok để í

:cheers:

<<

Còn một cách này nữa:

1) Dùng lệnh Cad:

 

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

-...

>>

Còn một cách này nữa:

 

1) Dùng lệnh Cad:

 

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

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

 

2) Dùng lisp:

 

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

 

(defun C:ARE( / p S Pe)
(setq p (getpoint "\nPick a internal point:"))
(command "boundary" p "" "Y")
(command "area" "o" (entlast))
(setq
S (getvar "area")
Pe (getvar "perimeter")
)
(command "erase" (entlast) "")
(alert (strcat "Area = " (rtos S) "\nPerimeter = " (rtos Pe)))
)

<<

Không hiểu ý bạn.

- chức năng cho phép đếm 1 đối tượng : ý bạn là đếm các LINE, ARC, ......

>>

Không hiểu ý bạn.

- chức năng cho phép đếm 1 đối tượng : ý bạn là đếm các LINE, ARC, ... ?

Nếu đúng, bạn có thể sử dụng Tools -> Palettes -> Properties để xem.

hoặc tham khảo Lisp Thống kê Block : http://www.cadviet.com/forum/index.php?sho...ost&p=94041

 

Lisp Thống kê Text trên bản vẽ .

Bổ sung sắp xếp TEXT và tạo bảng (Table)

(defun c:tkt(/ ent h height i len0 lst msp pt row ss str str0 str_len tblobj width0 width1); thong ke text;;  By : Gia Bach, Copyrightｩ December 2010                    ;;;;  Contact : gia_bach @  www.CadViet.com                      ;;  (defun TxtWidth (val msp / txt minp maxp)    (vla-getBoundingBox (setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) 1)) 'minp 'maxp)    (vla-Erase txt)    (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )  ;main  (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)    (progn      (vl-load-com)      (princ "\nChon cac Text de thong ke :")      (if (setq ss (ssget(list (cons 0 "TEXT"))))	(progn	  (setq i -1 len0 8)	  (while (setq ent (ssname ss (setq i (1+ i))))	    (setq str(cdr(assoc 1 (entget ent ))))	    (if (> (setq str_len (strlen str)) len0)	      (setq str0 str len0 str_len) )	    (if (not (assoc str lst))	      (setq lst (cons (cons str 1) lst))	      (setq lst (subst (cons str (1+ (cdr (assoc str lst))))			       (assoc str lst) lst)))	    )	  (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))		msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))	  (or *h* (setq *h* 175))	  (initget 6)	  (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))	  (if h (setq *h* h) (setq h *h*) )	  (setq width0 (* 3 h(TxtWidth "STT" msp))		height (* 2 h))	  (if str0	    (setq width1 (* 1.2 h(TxtWidth (strcase str0) msp)))	    (setq width1 (* 2 h(TxtWidth "Gia tri" msp))))	  (if (> h 3)	    (setq width0 (* (fix (/ width0 10))10)		  width1 (* (fix (/ width1 10))10)		  height (* (fix (/ height 5))5)))	  (setq pt (getpoint "\nDiem dat Bang :")		TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 3 height width1))	  (vla-put-regeneratetablesuppressed TblObj :vlax-true)	  (vla-put-vertcellmargin TblObj (* 0.25 h))	  (vla-put-horzcellmargin TblObj (* 0.75 h))	  (vla-SetColumnWidth TblObj 0 width0)	  (vla-SetColumnWidth TblObj 2 (* 2 h(TxtWidth "So luong" msp)))	  (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))		  (list acTitleRow acHeaderRow acDataRow) )	  (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))		  (list acTitleRow acHeaderRow acDataRow))	  (vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (vla-MergeCells TblObj 0 0 0 2)) )))	  (vla-setText TblObj 0 0 "Bang thong ke")	  (vla-setText TblObj 1 0 "STT")	  (vla-setText TblObj 1 1 "Gia tri")	  (vla-setText TblObj 1 2 "So luong")	  (setq i 1 row 2 )	  (foreach e lst	    (vla-setText TblObj row 0 (itoa i))	    (vla-setText TblObj row 1 (car e))	    (vla-setText TblObj row 2 (cdr e))	    (vla-SetCellAlignment TblObj row 1 7)	    (vla-SetCellAlignment TblObj row 2 9)	    (setq row (1+ row) i (1+ i))	)	  (vla-put-regeneratetablesuppressed TblObj :vlax-false)	  (vlax-release-object TblObj)	  )	(alert "Khong chon duoc Text.")    )      (princ)  )    (alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)")   )  )

Bác nào check lại hộ mình sao lỗi này với, khi load lisp thì nó báo:  APPLOAD tkt.lsp successfully loaded. Command: ; error: malformed list on input

<<

Download lisp

Filename: 350495_tkt.lsp