Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình...

>>

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình thường

(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
 (vl-load-com)  
 (if (setq ss (ssget(list (cons 0 "HATCH"))))
   (progn
     (foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
       (setq lay (vla-get-layer e) ar (vla-get-area e))
       (if (not (assoc lay lst))
         (setq lst (cons (cons lay ar) lst))
         (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                          (assoc lay lst) lst)))      )
     (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
		tl 0.000001
           pt (getpoint "\nDiem dat Bang :" )
           txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
           msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
     (foreach e lst
       (vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
       (vla-addtext msp 
	(strcat (rtos (* (cdr e) tl) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
       (setq pt (polar pt (/ pi -2) (* 1.5 txtsiz)))  )      )
   (alert "Khong chon duoc Hatch.")    )
 (princ))

Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.

Từ Cad 2006, Hatch mới có thuộc tính Area.

 

Bạn nên kiểm tra đ/kiện này truoc khi quyết định đi tiếp ...

(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)

(progn

...

))

<<

Phiphi dùng lisp IMF (insert multi files) dưới đây

 

(defun c:imf()
 (setq pathname (vl-filename-directory (getfiled "Hay chon file dwg bat ky thuoc thu muc" ""...
>>

Phiphi dùng lisp IMF (insert multi files) dưới đây

 

(defun c:imf()
 (setq pathname (vl-filename-directory (getfiled "Hay chon file dwg bat ky thuoc thu muc" "" "dwg" 0))
filelist (vl-sort (vl-directory-files pathname "*.dwg") '	p (getpoint "\nDiem chen: ")
xht (car p)
yht (cadr p)	
 )
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (foreach filename filelist    
   (command "-insert" (strcat pathname "/" filename) (list xht yht) 1.0 1.0 0.0)
   (vla-getboundingbox (vlax-ename->vla-object (entlast)) 'p1 'p2)    
   (setq
     p1 (vlax-safearray->list p1)
     p2 (vlax-safearray->list p2)      
     xht (+ xht (abs (car (mapcar '- p2 p1))))
     blname (cdr (assoc 2 (entget (entlast))))
   )
   (command ".explode" (entlast) "")    
   (command "-purge" "Block" blname "N")
 )
 (setvar "osmode" oldos)
 (princ)
)

Chào bác Hoành.

Đọc cái líp của bác và chạy hử mình thấy có thắc mắc như sau:

Tại sao theo lisp thì bác chỉ insert mỗi bản vẽ có 1 lần theo trật tự của cái filelist. Vậy mà kết quả thì mỗi bản vẽ được insert hai lần, một lần theo hàng ngang với đúng thứ tự của filelist và một lần nó tự sắp xếp thành một bảng có 5 cột và theo trật tự số từ 1 tới 23 bác ạ.

Vậy cái lần insert thú hai này là do đâu? Bác có thể giải thích thêm một chút chỗ này được không???

<<

Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons "KIEUDOITUONG" "TENLAYER") vào cụm...

>>

Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons "KIEUDOITUONG" "TENLAYER") vào cụm các lệnh cons phía dưới.

 

(defun c:o2l ( / ss pp lstoblayer)
 (setq
   lstoblayer
    (list
      (cons "DIMENSION" "DIM")		; chuyen doi tuong Dimension ve layer DIM 
      (cons "HATCH" "HATCH")
      (cons "INSERT" "BLOCK")		; BLOCK (la doi tuong insert) ve layer BLOCK
      (cons "*TEXT" "TEXT")		; TEXT va MTEXT ve layer text
    )    
 )

 (foreach pp lstoblayer    
   (setq ss (ssget "X" (list (cons 0 (car pp)))))
   (if (not (tblsearch "layer" (cdr pp)))
     (command ".layer" "m" (cdr pp) "")
   )
   (command ".chprop" ss "" "la" (cdr pp) "")    
 )  
 (princ)
)

 

Cảm ơn bác nhiều lắm, bác giúp nốt e 1 tí nữa, em dốt lisp lắm :cheers:

Như lisp bác viết thì khi ta dùng lệnh o2l nó sẽ chuyển tất cả, trong 1 file lisp em muốn tách riêng biệt từng lệnh có được không?

Ví dụ:

d2d chuyển các dim về layer DIM

h2h: chuyển các hatch về layer HATCH

b2b: chuyển các block về layer BLOCK

t2t: chuyển các text về layer TEXT

(Các lệnh để trong 1 file lisp thôi bác nhé)

<<

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại...

>>

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại chỗ tùy ý để bạn tiện ghi chú

 

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
 (progn  
 (vl-load-com)
 (acet-sysvar-set (list "cmdecho" 0))
 (grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
 (Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch :  ")
 (if (setq ss (ssget(list (cons 0 "HATCH"))))
   (progn
     (foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
	(setq lay (vlax-get-property e 'Layer))	
       (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
		(setq ar (*  0.000001 (vlax-get-property e 'Area)))
		(progn
			(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
			(redraw (vlax-vla-object->ename e) 3)
		)
	)			
       (if (not (assoc lay lst))
         (setq lst (cons (cons lay ar) lst))
         (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                          (assoc lay lst) lst))))
     (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))            
           txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
           msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
     (while (setq e (nth (setq i (1+ i)) lst))		
       (vla-addtext msp (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") (vlax-3d-point '(0 0 0)) txtsiz)
	(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
	(command ".move" (entlast) "" '(0 0 0) pt)
	)
		(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
   (alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
 (acet-sysvar-restore)(princ))
 (defun st-ss->ent	(ss / n e l)
 (setq n -1)
 (while (setq e (ssname ss (setq n (1+ n))))
   (setq l (cons e l))
 )
)

 

Cảm ơn bạn Ketxu! Lisp này chạy rất tốt. Chân thành cảm ơn bạn!

<<

Bác hoành hướng dẫn cho em sử dụng cái lisp này với .Em đã load xong ,thực hiện các bước trong command mà kết quả không ra như ý:

(defun C:hh()
 ...
>>

Bác hoành hướng dẫn cho em sử dụng cái lisp này với .Em đã load xong ,thực hiện các bước trong command mà kết quả không ra như ý:

(defun C:hh()
  (setq P1 (getpoint p1 "\nDiem dau : "))
  (setq P2 (getpoint p1 "\nDiem cuoi : "))
  (setq P3 (getpoint p1 "\nPhia co duong han : "))
  (setq  l (getdist p1  "\nChieu cao duong han : "))
  (setq goc (angle p1 p2))

  (setq xA (car P1))
  (setq yA (cadr P1))
  (setq xB (car P2))
  (setq yB (cadr P2))
  (setq xC (car P3))
  (setq yC (cadr P3))

  (setq dau (- (* (- xC xA) (- yB yA))
               (* (- xB xA) (- yC yA))
            )
  )

  (setq n (distance P1 P2))

  (setq x1 (- xA (* l (cos goc))))
  (setq y1 (- yA (* l (sin goc))))

  (While (> n 0)
     (setq x1 (+ x1 (* l (cos goc))))
     (setq y1 (+ y1 (* l (sin goc))))

     (setq x2 (- x1 (* l (sin goc))))
     (setq y2 (+ y1 (* l (cos goc))))

     (setq x3 (+ x1 (* l (sin goc))))
     (setq y3 (- y1 (* l (cos goc))))

     (setq dau2 (- (* (- x2 xA) (- yB yA))
                   (* (- xB xA) (- y2 yA))
                )
     )

     (if (> (* dau2 dau) 0)       
       (command "line" (list x1 y1) (list x2 y2) "")
       (command "line" (list x1 y1) (list x3 y3) "")
     )
     (setq n (- n l))
  ) ;of while
); of defune

 

Ý nghĩa của các câu hỏi mà lisp hiển thị:

- Diem dau : là điểm bắt đầu đường hàn

- Diem cuoi: Là điểm cuối cùng của đường hàn

- Phia co duong han: phía có đường hàn

- Chieu cao duong han: Chiều cao của đường hàn

Quá dễ để hiểu, không rõ là bạn thắc mắc ở điểm nào?

<<

Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)

(defun c:ft()
(setq txt (ssget '((0 ....
>>

Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" "" txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(setvar "textstyle" olstyle)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
);defun
;====================================================================
;dan deu khoang cach cac hang text theo phuong Y
;====================================================================
(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)
);setq
);repeat
(reverse lstent)
)
(defun c:df()
(setq oldos (getvar "osmode"))
(setq 	ss (ssget '((0 . "*TEXT")))
lst (ss2ent ss)
lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))
lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))
);setq
(command "undo" "begin")
(setvar "osmode" 15359)
(setq kc (getdist "\n Nhap khoang cach giua cac text"))
(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 a2 (ssadd))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq ptmau (cdr(assoc 10 mau)))
(setq ym (cadr ptmau))
(foreach e lst
(setq ent (entget e))
(setq dcuoi (cdr(assoc 10 ent)))
(setq yi (cadr dcuoi))
(setq ddauu (list (car dcuoi) (- (cadr ddau) (* i kc))))
(if (= yi ym) (setq ptgoc (list (car dcuoi) (- (cadr ddau) (* i kc)))))
(setvar "osmode" 0)
(command "move" e "" dcuoi ddauu)
(setq 	a2 (ssadd e a2))
(setq i (1+ i))
);foreach
(command "move" a2 "" ptgoc ptmau)
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)
;======================================================================
;dan deu khoang cach cac text theo phuong X
;======================================================================
(defun c:dfx()
(setq oldos (getvar "osmode"))
(setq 	ss (ssget '((0 . "*TEXT")))
lst (ss2ent ss)
lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))
lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))
);setq
(command "undo" "begin")
(setvar "osmode" 15359)
(setq kc (getdist "\n Nhap khoang cach giua cac text"))

(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 di 0 a2 (ssadd))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq ptmau (cdr(assoc 10 mau)))
(setq xm (car ptmau))
(foreach e lst
(setq ent (entget e))
(setq pti (cdr(assoc 10 ent)))
(setq xi (car pti))
(setq ddauu (list (+ (car ddau) di (* i kc)) (cadr ddau)))
(if (= xi xm) (setq ptgoc (list (+ (car ddau) di (* i kc)) (cadr ddau))))
(setq TBi  (textbox ent) LCi  (car TBi) RCi (cadr TBi) dii (distance LCi RCi) di (+ di dii))
(setvar "osmode" 0)
(command "move" e "" pti ddauu)
(setq 	a2 (ssadd e a2))
(setq i (1+ i))
);foreach
(command "move" a2 "" ptgoc ptmau)
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)
;==================================================================
;Sap xep text thang hang (co cung tung do Y)
;==================================================================
(defun c:dx()
(setq oldos (getvar "osmode"))
(setq txt (ssget '((0 . "TEXT"))))
(command "undo" "begin")
(setq ym (cadr (cdr(assoc 10 (entget (car (entsel "\nChon text chuan")))))) i 0)
(repeat (sslength txt)
(setq txt_pt (cdr(assoc 10 (entget (ssname txt i)))))
(setq ptcuoi (list (car txt_pt) ym))
(setvar "osmode" 0)
(command "move" (ssname txt i) "" txt_pt ptcuoi)
(setq i (+ i 1))
);repeat
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)

<<

 

- học tới ssget mà quên mất ^^, nhoc mông má lại cái lsp tính trung bình cộng, trong trường hợp bạn đó có trục trặc khi...

>>

 

- học tới ssget mà quên mất ^^, nhoc mông má lại cái lsp tính trung bình cộng, trong trường hợp bạn đó có trục trặc khi sử dụng lsp cũ sẽ có lsp mới để test lại ^^

;;ham tao text
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(defun C:tbcc(/ c tong oldob oldos txtstr realk mastyle malayer xtext num gstyle glayer tam tong tbc p ss)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
  (setq ss (ssget '((0 . "TEXT") (1 . "~*@*"))))
  (setq c 0 tong 0)
  (if (/= ss nil)
    (while (< c (sslength ss))
      (setq oldob (entget (ssname ss c)))
      (setq txtstr (assoc 1 oldob))
	  (setq realk (assoc 40 oldob))
	  (setq mastyle (assoc 7 oldob))
	  (setq malayer (assoc 8 oldob))
	(if (/= txtstr nil)
        (progn
		  (setq ctext (cdr realk))
          (setq num (cdr txtstr))
		  (setq gstyle (cdr mastyle))
		  (setq glayer (cdr malayer))
          (setq tam (atof num))
          (setq tong (+ tong tam))
		  (setq tbc (/ tong (sslength ss)))
        );progn
      );if
      (setq c (1+ c))
    );while
  );if
    (setq p (getpoint "\nNhap vi tri xuat ket qua: "))
	(if (= tbc 0)
    (mktext p ctext (rtos tbc 2 0) "L" glayer gstyle 1)
	(mktext p ctext (rtos tbc 2 3) "L" glayer gstyle 1)
	)
(setvar "cmdecho" 1)
(setvar "osmode" oldos)
(princ)	   
)
(prompt "ten lenh : tbcc")

 

Cách tốt nhất là sử dụng hàm distof để lọc số, tránh dùng hàm (setq ss (ssget '((0 . "TEXT") (1 . "~*@*")))) để lọc số, bởi nó không lường hết các trường hợp Text không phải là số 

<<

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy...

>>

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy được các bản cad 2004, 2005 và 2006 nên mình viết một lisp tương tự để chạy được trên tất cả các bản cad.

- Lisp yêu cầu chọn tất cả các text (Dtext va MText) cần căn lề.

- Chọn một text làm chuẩn để căn lề các text đã chọn theo text đó

- Ngoài chức năng căn lề theo 3 vị trí. Left, Center, Right thì lisp này cung cấp thêm chức năng căn lề theo kiểu Fit, - kéo dãn các dòng cho dài bằng nhau (giống word) và dài bằng text chọn làm chuẩn.

(defun c:ft()
......
(prompt "\nchon cac text can can le ...")
(setq txt (ssget '((0 . "*TEXT"))))
........
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
......

Chào Thaistreetz.

Tue_NV có ý kiến chút nhé :

1. Trong Lisp thể hiện chọn các Text và Mtext như của bạn viết thể hiện qua dòng Code này :

(setq txt (ssget '((0 . "*TEXT"))))

Nhưng khi thể hiện lại thì qua những dòng code mà Tue_NV đã trích dẫn thì toàn bộ MText ban đầu đã chuyển thành Text cả. Như vậy là không phù hợp

2. Bạn xem lại trong code 1 chút nhé. Khi chọn Text chuẩn trúng đối tượng TEXT thì đúng nhưng khi Pick trúng đối tượng MTEXT thì báo lỗi ngay.

<<

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...
>>

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)	       
)

lips rất hay thank nhe

<<

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy...

>>

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy được các bản cad 2004, 2005 và 2006 nên mình viết một lisp tương tự để chạy được trên tất cả các bản cad.

- Lisp yêu cầu chọn tất cả các text (Dtext va MText) cần căn lề.

- Chọn một text làm chuẩn để căn lề các text đã chọn theo text đó

- Ngoài chức năng căn lề theo 3 vị trí. Left, Center, Right thì lisp này cung cấp thêm chức năng căn lề theo kiểu Fit, - kéo dãn các dòng cho dài bằng nhau (giống word) và dài bằng text chọn làm chuẩn.

(defun c:ft()
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq olstyle (getvar "textstyle"))
(prompt "\nchon cac text can fit ...")
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5)) (cadr x1)))
(setq x3 (list (+ (car x1) di) (cadr x1)))
(setq canle (cond (canle) ("Trai")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" "" txt_fctr "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(setvar "textstyle" olstyle)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
);defun

Hiện tại thì mình đã khá hài lòng với lisp này nếu chỉ dùng để căn lề text. Tuy nhiên mình muốn thêm cho nó chức năng giãn dòng cho đều cũng với cách nhập số liệu như trên nhưng đang mắc về thuật giải. Xin nhờ mọi người giúp mình hoàn thiện lisp này với.

 

Đang mày mò cái này, THAI viết rồi thì copy một bản vậy. Thanks cái nè!!!!

<<

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy...

>>

Trước đây mình có thấy trong diễn đàn đã cung cấp công cụ căn lề text theo 3 kiểu Left, Center, Right. Tuy nhiên công cụ này ko viết bằng autolisp và chỉ chạy được các bản cad 2004, 2005 và 2006 nên mình viết một lisp tương tự để chạy được trên tất cả các bản cad.

- Lisp yêu cầu chọn tất cả các text (Dtext va MText) cần căn lề.

- Chọn một text làm chuẩn để căn lề các text đã chọn theo text đó

- Ngoài chức năng căn lề theo 3 vị trí. Left, Center, Right thì lisp này cung cấp thêm chức năng căn lề theo kiểu Fit, - kéo dãn các dòng cho dài bằng nhau (giống word) và dài bằng text chọn làm chuẩn.

(defun c:ft()
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq olstyle (getvar "textstyle"))
(prompt "\nchon cac text can can le ...")
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5)) (cadr x1)))
(setq x3 (list (+ (car x1) di) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" "" txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(setvar "textstyle" olstyle)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
);defun

Hiện tại thì mình đã khá hài lòng với lisp này nếu chỉ dùng để căn lề text. Tuy nhiên mình muốn thêm cho nó chức năng giãn dòng cho đều cũng với cách nhập số liệu như trên nhưng đang mắc về thuật giải. Xin nhờ mọi người giúp mình hoàn thiện lisp này với.

 

Edit: đã fix lỗi

Mình đã thử nhiều lần nhưng đều xuất hiện lỗi.chon cac text can can le ...too many arguments

Trước mình dùng lisp bình thường nhưng dạo này một số lisp rất hay xuất hiện lỗi too many arguments.có thể cho mình hỏi nguyên nhân và cách khắc phục được không??? thanks!

<<

(defun C:s2p ()
(while (not (and
		  (setq lstSelection   (entsel "\nSelect Spline: "))
		  (setq sngSegment	 (getdist "\nGet Segment Length: "))
		  (setq objSelection  ...
>>

(defun C:s2p ()
(while (not (and
		  (setq lstSelection   (entsel "\nSelect Spline: "))
		  (setq sngSegment	 (getdist "\nGet Segment Length: "))
		  (setq objSelection   (vlax-ename->vla-object (car
lstSelection)))
		  (wcmatch (vla-get-objectname objSelection) 

"AcDb2dPolyline,AcDbPolyline,AcDbLine,AcDbArc,AcDbSpline"
		  )
		 )
	)
 (princ "\nError please select again: ")
)
(setq sngLength   (vlax-curve-getDIstAtParam objSelection
				(vlax-curve-getEndParam objSelection)
			   )
   sngDistance 0.0
)
(vl-cmdf "._pline" (vlax-curve-getpointatDist objSelection 0.0))  (repeat (fix (/ sngLength sngSegment))
 (vl-cmdf (vlax-curve-getpointatDist objSelection sngDistance))
 (setq sngDistance (+ sngDistance sngSegment))
)
(vl-cmdf (vlax-curve-getPointAtParam objSelection
	   (vlax-curve-getEndParam objSelection)
	  )
	  ""
)
)

 

Đoạn mã trên đây cũng khá hay. bạn thử dùng nhé.

 

Bro có thể viết lisp sử dụng arc trong polyline được không , mình thấy nhiều đoạn thẳng quá

<<

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

>>

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua ma dxf block
;;;Cu phap su dung (duy:block_s_dxf block mdxf thanh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block_s_dxf (blk mdxf thanh /  e el name ob lname name mdxf thanh)
(setq name (cdr (assoc 2 (entget blk))))
(if (not (member name lname))
(progn
(setq lname (append lname (list name)))
(setq e (cdr (assoc -2 (tblsearch "BLOCK" name))))
(while e
(setq el (entget e))

(cond 
((wcmatch (cdr (assoc 0 el)) "INSERT") (block_s_dxf e mdxf thanh) )
)

(setq Ent (subst (cons mdxf thanh) (assoc mdxf el) el))
(entmod ent)
(setq e (entnext e))  
);while
);progn
);if
(command ".move" (ssget "x" (list (cons 0 "INSERT")(cons 2 name))) "" (list 0 0 0) (list 0 0 0))
)

(DEFUN C:dlb ()
(setq dttd (car(entsel "Chon BLOCK!")))
(block_s_dxf dttd 8 "0")
(block_s_dxf dttd 62 256)
)

@Pham Quoc DuyCái này ngon rồi nhưng bạn có thể edit lại tý xíu phần select object như trong cad không...ví dụ chọn đối tượng theo p, c, w, l, cp, wp...thk so much

 

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

 

>>

 

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

 

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:HA ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname (vla-get-Name obj)
          lay (vla-get-Layer obj))
    (mapcar '(lambda(o) (vla-put-Layer o lay)) (Get_lst_Obj doc blkname)))
   (vla-Regen doc acActiveViewport))))
(defun Get_lst_Obj (doc blkname / lst)
 (vlax-for blk (vla-Item (vla-get-Blocks doc) blkname)
  (if (/= (vla-get-ObjectName blk) "AcDbBlockReference")
   (if (not (vl-position blk lst))
    (setq lst (cons blk lst)))
   (setq lst (append (Get_lst_Obj doc (vla-get-Name blk)) lst)))))
 

Anh cho em hỏi luôn. em tải lisp này về, và dùng tại sao block của em không đổi về màu 8 ? mà vẫn giữ nguyên màu trắng???

em muốn dùng lisp chuyển toàn bộ block trong file đính kèm, chuyển thành màu 8 nhưng block vẫn giữ nguyên.

Tên lệnh: THS.

(defun c:ths (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)
(command "undo" "be")
(setq donvi (/ (getvar...
>>

Tên lệnh: THS.

(defun c:ths (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)
(command "undo" "be")
(setq donvi (/ (getvar "viewsize") 40))
(setq ddd (entsel "\nChon text bi tru"))
(while
(or
  (null ddd)
  (/= "TEXT" (cdr (assoc 0 (entget (car ddd)))))
)
(princ "\nDoi tuong khong phai la text! Chon lai")
(setq ddd (entsel "\nChon text bi tru"))
)

 (setq DTDTT (car ddd))
 (setq DTTT (entget DTDTT))
 (setq NDTTT (cdr (assoc 1 DTTT)))
 (setq NDTTT (atof NDTTT))
 (setq DIEMVIETTEXT (cdr (assoc 10 DTTT)))
(setq diemvt1 (polar DIEMVIETTEXT pi donvi))
(setq diemvt2 (polar DIEMVIETTEXT (* 2 pi) donvi))
(setq diemvt3 (polar DIEMVIETTEXT (/ pi 2) donvi))
(setq diemvt4 (polar DIEMVIETTEXT (- 0 (/ pi 2)) donvi))
       	(grdraw diemvt1 diemvt2 3)
       	(grdraw diemvt3 diemvt4 3)
(if (= droffln nil)
(setq droffln1 2.00)
(setq droffln1 droffln)
)
(setq
droffln (GETREAL (strcat "\nNhap hang so tru: <" (rtos droffln1 2 2) ">"))
)
(if (= droffln nil)
(setq droffln droffln1)
)

(setq ketquaxuat (- NDTTT droffln))
(setq ketquaxuat (rtos ketquaxuat 2 2))
(setq dddsn (entsel "\nChon text xuat ket qua"))
(while
(or
  (null dddsn)
  (/= "TEXT" (cdr (assoc 0 (entget (car dddsn)))))
)
(princ "\nDoi tuong khong phai la text! Chon lai")
(setq dddsn (entsel "\nChon text tru"))
)

  		(setq DTDTTsn (car dddsn))
  		(setq DTMs (entget DTDTTsn))
  		(setq DTMs (subst (cons 1 ketquaxuat) (assoc 1 DTMs) DTMs))
  		(entmod DTMs)

(command "undo" "end")
 	(Princ))

Nhờ mọi người sửa giúp mình bổ sung cho Lisp trên thêm cộng, nhân, chia, với. (hiện tại chỉ có trừ thôi).

Thanks!

<<

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

Đối với phép + và * bạn có thể chọn 1 lúc nhiều số, còn - và / thì chỉ có 2 số thôi.

 

>>

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

Đối với phép + và * bạn có thể chọn 1 lúc nhiều số, còn - và / thì chỉ có 2 số thôi.

 

(defun c:tinh()  (initget 1 "+ - * /")  (setq ptinh (getkword "Chon phep tinh <+ - * />: "))    (cond ((= ptinh "+")  ;;; cong     (prompt "\nChon text de cong:")     (setq ss (ssget '((0 . "TEXT")))           tong 0)     (while (and ss (> (sslength ss) 0))       (setq tong (+ tong (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))       (ssdel ent ss))     (princ tong))		((= ptinh "*")  ;;;nhan     (prompt "\nChon text de nhan:")     (setq ss (ssget '((0 . "TEXT")))           tong 1)     (while (and ss (> (sslength ss) 0))       (setq tong (* tong (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))       (ssdel ent ss))     (princ tong))	((= ptinh "-")  ;;;tru     (setq sobitru (car (entsel "\nChon so bi tru:"))           sotru (car (entsel "\nChon so tru:\n"))           kq (- (atof (cdr (assoc 1 (entget sobitru))))	         (atof (cdr (assoc 1 (entget sotru))))))  	     (princ kq))	((= ptinh "/")  ;;;chia     (setq sobichia (car (entsel "\nChon so bi chia:"))           sochia (car (entsel "\nChon so chia:\n"))           kq (/ (atof (cdr (assoc 1 (entget sobichia))))	         (atof (cdr (assoc 1 (entget sochia))))))  	     (princ kq))  	)    (princ)           )

Lisp rất hay bạn có thể bổ sung thêm các đối tượng text có thể chọn từ bản vẽ hoặc cũng có thể nhập từ bàn phím

<<

bạn dùng thử lisp này

(defun C:TRU (/ OLDDIMZIN SS SOTRU DSSBT SBT)
 (vl-load-com)
 (setq OLDIMZIN (getvar "DIMZIN"))
 (setvar "DIMZIN" 0)
 (princ "\nChon cac so bi...
>>

bạn dùng thử lisp này

(defun C:TRU (/ OLDDIMZIN SS SOTRU DSSBT SBT)
 (vl-load-com)
 (setq OLDIMZIN (getvar "DIMZIN"))
 (setvar "DIMZIN" 0)
 (princ "\nChon cac so bi tru")
 (setq SS (ssget '((0 . "TEXT"))))
 (if _SOTRU
(progn
  (initget 4)
  (if (null (setq SOTRU (getreal (strcat "\nNhap so tru: <" (rtos _SOTRU) "> "))))
(setq SOTRU _SOTRU)
  ) 
) 
(progn
  (initget (+ 1 4))
  (setq SOTRU (getreal "\nNhap so tru: "))
) 
 ) 
 (setq DSSBT (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))))
 (foreach SBT DSSBT (vla-put-textstring SBT (rtos (- (atof (vla-get-textstring SBT)) SOTRU))))
 (setq _SOTRU SOTRU)
 (setvar "DIMZIN" OLDIMZIN)
 (princ)
)

 

 

không biết sao mình dùng thử lisp trên thì bị báo lỗi, nhờ bạn xem lại hộ mình với. Thanks!

<<

Đọc chưa hết bài nhưng mình có lsp cắt được dim có chênh cao Z spam lên cho các bạn khì khì.

(DEFUN C:CD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14...
>>

Đọc chưa hết bài nhưng mình có lsp cắt được dim có chênh cao Z spam lên cho các bạn khì khì.

(DEFUN C:CD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI 
                                 PT13I PT14I PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
;;;(SETQ OLDERR *error*
;;;      *error* myerror)
(PRINC "Lam on chon duong kich thuoc bat ky can cat bo Duong oi:")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Con moi bo Duong nhap diem gioi han duong kich thuoc a:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
   (PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
   (PROGN
	(SETQ PT10 (CDR (ASSOC 10 DS)))
	(SETQ PT11 (CDR (ASSOC 11 DS)))
	(SETQ PT13 (CDR (ASSOC 13 DS)))
	(SETQ PT14 (CDR (ASSOC 14 DS)))
	(SETQ PT10 (LIST (CAR PT10) (CADR PT10) 0.00))
	(SETQ PT11 (LIST (CAR PT11) (CADR PT11) 0.00))
	(SETQ PT13 (LIST (CAR PT13) (CADR PT13) 0.00))
	(SETQ PT14 (LIST (CAR PT14) (CADR PT14) 0.00))
	(SETQ N70 (CDR (ASSOC 70 DS)))
	(IF (OR (= N70 0) (= N70 32) (= N70 33) (= N70 160) (= N70 161))
	   (PROGN
		(SETQ GOCY (ANGLE PT10 PT14))
		(SETQ GOCX (+ GOCY (/ PI 2)))
	   )
	)
	(SETVAR "OSMODE" 0)
	(SETQ PTI (POLAR PT GOCX 2))
	(SETQ PT13I (POLAR PT13 GOCY 2))
	(SETQ PT14I (POLAR PT14 GOCY 2))
	(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
	(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
	(SETQ O13 (ASSOC 13 DS))
	(SETQ O14 (ASSOC 14 DS))
	(SETQ N13 (CONS 13 PT13N))
	(SETQ N14 (CONS 14 PT14N))
	(SETQ DS (SUBST N13 O13 DS))
	(SETQ DS (SUBST N14 O14 DS))
	(ENTMOD DS)
   )
)
(SETQ DEM (+ DEM 1))
   )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
;;;(setq *error* OLDERR)               ; Restore old *error* handler
(PRINC)
)
;******************************************************************************

(DEFUN C:BD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI
               PT10 PT10I PT10N O10 N10 PT11 PT11N O11 N11 KC OSM OLDERR)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
;;;(SETQ OLDERR *error*
;;;      *error* myerror)
(PRINC "Chon diem dau bo Duong oi")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Diem ket thuc nua bo Duong a:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
   (PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
   (PROGN
	(SETQ PT13 (CDR (ASSOC 13 DS)))
	(SETQ PT14 (CDR (ASSOC 14 DS)))
	(SETQ PT10 (CDR (ASSOC 10 DS)))
	(SETQ PT11 (CDR (ASSOC 11 DS)))
	(SETQ N70 (CDR (ASSOC 70 DS)))
	(IF (OR (= N70 0) (= N70 32) (= N70 33) (= N70 160) (= N70 161))
	   (PROGN
		(SETQ GOCY (ANGLE PT10 PT14))
		(SETQ GOCX (+ GOCY (/ PI 2)))
	   )
	)
	(SETVAR "OSMODE" 0)
	(SETQ PTI (POLAR PT GOCX 2))
	(SETQ PT10I (POLAR PT10 GOCY 2))
	(SETQ PT10N (INTERS PT PTI PT10 PT10I NIL))
	(SETQ KC (DISTANCE PT10 PT10N))
	(SETQ O10 (ASSOC 10 DS))
	(SETQ N10 (CONS 10 PT10N))
	(SETQ DS (SUBST N10 O10 DS))
	(SETQ PT11N (POLAR PT11 (ANGLE PT10 PT10N) KC))
	(SETQ O11 (ASSOC 11 DS))
	(SETQ N11 (CONS 11 PT11N))
	(SETQ DS (SUBST N11 O11 DS))
	(ENTMOD DS)
   )
)
(SETQ DEM (+ DEM 1))
   )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
;;;(setq *error* OLDERR)
(PRINC)
)

Hề hề hề,

Âu cũng là có tí khè hỉ????

 

Cám ơn bác đã chia xẻ, song giá như không có "bo Duong" thì lisp sẽ tuyệt hơn nhiều bác ạ....

<<

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

;/Day la lenh OFFSET dac...
>>

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

 

- Mình có cái lisp offset này nhưng mỗi lần chạy lisp lại phải nhập khoảng cách để offset. Mình nhờ các bạn chỉnh giúp mình lisp này có thể lưu lại thông số đã nhập cho lần thực hiện sau (nếu mình không nhập khoảng cách mới thì nó sẽ lấy số được nhập lần trước)

 

Cảm ơn các bạn nhiều!

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

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

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

)

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

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

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

(defun C:OO (/ lay lt os kc msg1 p1 msg2)

        (setq   os (getvar "Osmode")

lt (getvar "celtype")

                lay (getvar "Clayer")

                msg1 "\nVao khoang cach offset: "

                kc (getreal msg1)

                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")

        );het setq

        (setvar "OSMODE" 512)

        (setq   p1 (getpoint msg2))

(while p1

(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")

        (setq   p1 (getpoint msg2))

);het while

        (setvar "OSMODE" os)

)

Hề hề hề,

Bác thử sửa dòng code: 

   kc (getreal msg1)

 thành:

   kc (if msg1 (getreal msg1) kc)

và xóa biến kc ở trong dòng liệt kê biến cục bộ đi 

Sau đó bác test lại coi sao.

<<

Theo đúng yêu cầu, bạn thử xem nhé!

lệnh là DTM (diện tích miền)

(defun c:dtm()
 (defun ctext (diem gt / lst)    
   (setq lst
   (list
     (cons 0...
>>

Theo đúng yêu cầu, bạn thử xem nhé!

lệnh là DTM (diện tích miền)

(defun c:dtm()
 (defun ctext (diem gt / lst)    
   (setq lst
   (list
     (cons 0 "TEXT")
     (cons 1 gt)
     (cons 10 diem)
     (cons 40 (getdist p "\nChieu cao chu: "))
   )
   )
   (entmake lst)
 )
 (defun dtdoituong (entdt /)
   (command ".area" "o" entdt)
   (command ".erase" entdt "")
   (getvar "area")
 )
 (defun getbound(p)
   (setq ent (entlast))
   (command ".boundary" "A" "B" "E" "I" "Y" "" p "")
   (setq ent1 (entlast))
   (cond
     ((eq ent ent1) nil)
     (t ent1)
   )
 )
 (setq
   p (getpoint "\nVao diem can tinh dien tich: ")
   entpl (getbound p)	
 )
 (if entpl
   (ctext p (rtos (dtdoituong entpl)))
   (alert "Diem ban chon khong kin!")
 )
 (princ)
)

 

Lisp trên rất cơ bản, chỉ tính đúng với các miền không có "lỗ thủng".

Nhờ các bạn sửa giúp lisp này để tôi có thể tính tổng diện tích cho nhiều đối tượng ( nhiều miền 1 lúc) , yêu cầu là pick chọn miền thứ 1, miền thứ 2... phải chuột , chương trình hỏi chiều cao chữ và vị trí đặt chữ mang giá trị tổng diện tích . Xin cảm ơn nhiều.

<<