...........

giả sử có 10 hàng text mỗi hàng có canh lề khác nhau và hàng đầu tiên là canh lề left chẳng hạn thì bây giờ mình muốn MA 9 hàng text...

>>

...........

giả sử có 10 hàng text mỗi hàng có canh lề khác nhau và hàng đầu tiên là canh lề left chẳng hạn thì bây giờ mình muốn MA 9 hàng text sau theo canh lề left của hàng đầu tiên, mà ko bị nhảy lung tung. MA các canh lề khác cũng tương tự. thank vì sự hợp tac.

mình có file đi kèm nè.

nếu chữ to nhỏ khác nhau

................

Chào oizdoi_oi

Bạn chạy thử LISP này.

(defun c:MJT(/ ent ss data elst id) ; MJT -> Matchprop_Justify_Text
 (vl-load-com)
 (command "UNDO" "begin")
 (defun dxf(id data) (cdr (assoc id data)) )
 (defun dataMod (code val data) (subst (cons code val)  (assoc code data) data));databae Modify
; ham chinh
 (while 
   (not
     (and
(setq ent (car (entsel "\nChon Text chuan : ")))
(if ent (= (cdr (assoc 0 (entget ent))) "TEXT") )
)
     )
   (princ "\nChon lai : ")
   )
 (princ "\nChon Text can thay doi : ")
 (if (setq ss (ssget '((0 . "TEXT")) ))
   (progn
     (setq data (entget ent))
     (foreach elst  (mapcar 'entget
                      (vl-remove-if 'listp
                        (mapcar 'cadr (ssnamex ss))))
; thuoc tinh
(foreach id (list 8 40 7 62 6 48 370);layer height textstyle color linetype linetypescale lineweight
  (if (dxf id data)
    (if (dxf id elst)
      (setq elst (dataMod id (dxf id data) elst))
      (setq elst (append elst (list (cons id (dxf id data)))) )
      )
    (if (dxf id elst)
      (cond
	((eq id 62) (setq elst (dataMod id 256 elst)))
	((eq id 48) (setq elst (dataMod id 1 elst)))
	((eq id 6)  (setq elst (dataMod id "ByLayer" elst)))
	((eq id 370)(setq elst (dataMod id -1 elst)))		
	)
      )
    )
  )
; vi tri
(setq elst (subst (cons 10 (list (cadr (assoc 10 data))
				 (caddr (assoc 10 elst))
				 (cadddr (assoc 10 elst))))
		  (assoc 10 elst) elst)
      elst (dataMod 11 (dxf 10 elst) elst)	      
      elst (dataMod 72 0 elst)
      )
(entmod elst)
)
     )
   )
   (command "UNDO" "end")
 (princ)
 )

<<

Theo em thì do bác NTD này ko diễn đạt đúng ý đồ thôi, em là một thợ vẽ nên thường dụng tới thằng này lắm, khi có một mặt bằng và...

>>

Theo em thì do bác NTD này ko diễn đạt đúng ý đồ thôi, em là một thợ vẽ nên thường dụng tới thằng này lắm, khi có một mặt bằng và muốn vẽ 4 mặt đứng xung quanh: thay vì phải copy ra một mặt bằng nữa rồi vẽ xong mặt đứng này lại phải quay cái mặt bằng vừa copy ra để vẽ tiếp cái khác===> vừa nặng máy vừa khó đối chiếu mặt đứng với MB

Vì vậy sữ dụng lệnh Plan để vẽ 4 mặt đứng nằm xung quanh cái MB. có lẽ đây là "View port bên Model" của bác ấy?!

Em xin góp một code để giảm phiền toái khi phải sữ dụng Plan nhiều. Lisp yêu cầu chọn đối tượng để zoom object và nhập vào góc quay. lệnh AS để thay đổi View, lệnh ASS để trở về Plan của UCS World

(defun c:AS(/ goc dtz)
(setq dtz (ssget)
  	goc (getreal "\nangle: "))
(command "ucs" "z" (* -1 goc) "")
(command "plan" "")
 (command "zoom" "o" dtz "")
(princ)
)
(defun c:AsS()
(command "ucs" "")
(command "plan" "")
(princ)
)

Chào các bác.

Em chưa biết nhiều về Ucs hay Plan lắm, nhưng thi thoảng thấy mấy anh trong phòng xoay view port bằng lệnh UCS rồi Plan gì đó (em chưa nhìn kịp) thì thấy cũng hơi lâu, Em thử chạy đoạn lisp của bác lp_hai thì thấy nhanh hơn, nhưng có điều nếu góc xoay là lẻ thì mình làm thế nào? Liệu có thể chọn góc xoay bằng cách pick 2 điểm không ạ? Em xin cảm ơn ạ!

<<

16 giờ trước, huunhantvxdts đã nói:

Đoạn này mình chưa làm...

>>

16 giờ trước, huunhantvxdts đã nói:

Đoạn này mình chưa làm được bạn có thể chỉnh lisp trên bỏ thao tác bắt đối tượng sau khi fillett cho mình với

Cám ơn bạn

 

17 giờ trước, CadExTools đã nói:

Thì chính là bắt đối tượng thông qua Ename của đối tượng đó bạn

 

20 giờ trước, Danh Cong đã nói:

Ý tưởng : Có khi nào mình xác định arc mới thông qua "Param" của nó phát sinh ra không nhỉ. ^^. Em chưa kiểm tra điều này bao giờ, ko biết đúng sai ra sao  :)))

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

Đối tượng PLine 1 có Ename + số đỉnh

Đối tượng Pline 2 cũng có Ename và số đỉnh.

Sau khi Fillet xong thì nếu thành công thì đối tượng tạo thành sẽ có Ename là 1 trong 2 thằng đó (Ktra xem đối tượng nào còn TỒN TẠI) -> Bắt đối tượng đó thông qua Ename bên trên, dựa vào số đỉnh ta lại suy ra được vị trí của cái cung tròn đó.

Tại hạ có hạ kiến như thế, các hạ vui lòng thử

Gộp ý tưởng của các bác + google tý viết được Lisp như thế này

Các bác test xem. 

Mình đã test trường hợp 2 pline, 1 pline và 1 line, 1 line và 1 arc đều sử dụng được, k biết còn trường hợp nào không ?

(defun C:VBK( / DTUONG1 DTUONG2 dtuong11 dtuong22 end )
(if (and
	      (setq dtuong1  (entsel "\nChon doi tuong 1"))
	      (setq dtuong2 (entsel "\nChon doi tuong 2"))
	      ) (progn
  		(setq dtuong11 (car dtuong1))
	      (setq dtuong22 (car dtuong2))
(if (= (Cdr (assoc 0 (entget dtuong11))) "LWPOLYLINE") (PROGN
  (setq end  (vlax-curve-getendparam dtuong11))
  (Polyline dtuong11 )
) (if (= (Cdr (assoc 0 (entget dtuong22))) "LWPOLYLINE") (progn
	(setq end  (vlax-curve-getendparam dtuong22))
  (Polyline dtuong22)
	) (progn
	    (command "fillet" "r" pause "")
		(command "FILLET" dtuong11 dtuong22)
	    (command "DIMRADIUS" (list (entlast) (cdr (assoc 10 (entget (entlast)))) ) "_non" "")
	    )))))
	(princ)
	)
(defun Polyline( dtuong / p11 cen lst ent )
  (command "fillet" "r" pause "")
  (command "_.FILLET" (osnap (cadr dtuong1) "_nea") (osnap (cadr dtuong2) "_nea"))
  (setq p11 (vlax-curve-getpointatparam dtuong end))
  (if (setq cen (osnap  p11 "_CEN")) (progn
  (command "Circle" "_non" cen (getvar 'filletrad) "")
   (setq ent (entlast))
(setq lst (list ent p11))
  (command "DIMRADIUS" lst "_non" "" )
  (entdel ent)))
  )

 

<<

Version 2.1: Tự động bật/Tắt chế độ gõ tiếng việt, tự động chuyển đổi bảng mã của Unikey khi chỉnh sửa hoặc tạo Text,...

>>

Version 2.1: Tự động bật/Tắt chế độ gõ tiếng việt, tự động chuyển đổi bảng mã của Unikey khi chỉnh sửa hoặc tạo Text, Mtext, Dimension

- Sửa lệnh Ed để nhận diện các text cần sửa tiếp theo. (Cảm ơn bạn Tien2005 đã hỗ trợ thuật toán ^^)

- Update hỗ trợ thêm thao tác kick đúp để chỉnh sửa text.

;===============================================================;
; 	A U T O   U N I K E Y   C O N T R O L   R O U T I N E 	;
;===============================================================;
;                                                       		;
;  Version 1.0 - 14/12/2012                             		;
;  	- Support Auto change table code (Unicode, TCVN, VNI)	;
;  	- Support for Text & Mtext objects               		;
;                                                       		;
;  Version 2.0 - 15/12/2012                             		;
;  	- Added Auto toggle (On/Off) Vietnamese keys     		;
;  	- Added support for Dimension objects                	;
;  	- fixed Check-font-code function                 		;
;                                                       		;
;  Version 2.1 - 22/01/2013                             		;
;  	- Added support for Double click to edit *text   		;
;  	- fixed ED command to select continues (thanks Tien2005) ;
;                                                       		;
;===============================================================;
;  	Cadviet.com - Le Thuy Linh 313 - Tri Tue Viet.jsc    	;
;===============================================================;
(vl-load-com)
;;; Go bo Reactor Auto-Unikey cu truoc khi load
(foreach x (cdar (vlr-reactors :vlr-sysvar-reactor))
(if (= (vlr-data x) "Auto-Unikey") (vlr-remove x)))
(foreach x (cdar (vlr-reactors :vlr-mouse-reactor))
(if (= (vlr-data x) "Double-Click") (vlr-remove x)))
;;; Tao Reactor Auto-Unikey
(vlr-mouse-reactor   "Double-Click" '((:vlr-beginDoubleClick . callback-DoubleClick)))
(vlr-sysvar-reactor "Auto-Unikey" '((:vlr-sysvarchanged . callback-Unikey)))
;;; Dinh nghia lai lenh ED de lay ename doi tuong
(defun c:ed (/ textedit font ent)
(and (or (and (setq textedit (ssget "I" '((0 . "*TEXT,DIMENSION"))))
      		(sssetfirst textedit)
      		(setq textedit (ssname textedit 0)))
     	(setq textedit (car (entsel))))
 	(while textedit
  	(setq ent (cdr (assoc 0 (entget textedit))))
  	(cond ((wcmatch ent "*TEXT")
         	(setq font (vla-get-stylename (vlax-ename->vla-object textedit))))
    		((= ent "DIMENSION")
         	(setq font (vla-get-textstyle (vlax-ename->vla-object textedit)))))
  	(command "ddedit" textedit "")
  	(setq textedit (car (entsel)))))
(princ))
;;; Ham callback dieu khien bo go tieng viet
(defun callback-Unikey (reactor sysvar / code Crfont)
(if (= (car sysvar) "TEXTEDITOR") (sendkeys "^+"))
(if (> (getvar "TEXTEDITOR") 0)
 (progn
  (if font (setq Crfont font) (setq Crfont (getvar "textstyle")))
  (setq code (check-font-code Crfont))
  (cond ((= code "TCVN3") (sendkeys "^+{F2}"))
		((= code "UNICODE") (sendkeys "^+{F1}"))
		((= code "VNI") (sendkeys "^+{F3}")))
  (setq font nil))))
;;; Ham callback lay textstyle khi Double Click vao text
(defun callback-DoubleClick (reactor point / sset obj ss)
(setq sset (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))))
(setq ss (vla-add sset "ThuyLinh313"))
(vla-selectatpoint ss (vlax-3d-point (car point)))
(if (> (vlax-get ss 'Count) 0)
 (progn
  (setq obj (vla-item ss 0))
  (if (or (eq (vlax-get obj 'ObjectName) "AcDbText")
  		(eq (vlax-get obj 'ObjectName) "AcDbMText"))
(setq font (vla-get-stylename obj)))
  (sssetfirst nil (ssadd (vlax-vla-object->ename obj)))))
(vla-delete ss))
;;; Ham kiem tra bang ma cua textstyle (su dung true type font)
;;; style: String - ten cua textstlye kiem tra
(defun Check-Font-Code (style / ts font Bold Italic charSet PitchandFamily)
(setq ts (vlax-ename->vla-object (tblobjname "style" style)))
(vla-GetFont ts 'font 'Bold 'Italic 'charSet 'PitchandFamily)
(if (= font "") (setq font (vla-get-fontfile ts)))
(cond ((wcmatch (setq font (strcase font)) "ARIAL*,TAHOMA*,TIMES*,COURIER NEW,CAMBRIA,CONSOLAS") "UNICODE")
((wcmatch font ".VN*") "TCVN3")
((wcmatch font "VNI*") "VNI")))
;;; Ham senkeys
(defun SendKeys (keys / wscript)
(vlax-invoke-method (setq wscript (vlax-create-object "WScript.Shell")) 'sendkeys keys)
(vlax-release-object wscript))

(Chú ý: cần thiết lập chế độ gõ tiếng anh mặc định khi sử dụng cad)

 

Từ ý tưởng của bạn Phamngoctukts thì mình nảy sinh ý định viết ứng dụng này để hỗ trợ với tất cả các loại text trong bản vẽ: attribute, text trong khối block, rtext... Hi vọng sẽ làm được trong các version tiếp theo :D

Cám ơn bạn. Thấy ý tưởng viết lisp này hay nhưng down về sd chưa đc, không hiểu cách dùng.

Mình mở cad tạo 3 đối tượng text, 1 là font ABC, 2 là font VNI, 3 là Unicode. Load CT, đánh lệnh ed thấy trình Unikey kg bật tắt đúng kiểu cần thiết. Đánh kiểu vni hay telex đều kg đc. Làm thế nào mới chạy đúng bạn nhỉ

<<

1 phút trước, Han Tinh đã nói:

Thanks bạn nha! chúng không cùng...

>>

1 phút trước, Han Tinh đã nói:

Thanks bạn nha! chúng không cùng tọa độ nha bạn, các text bị lệch nhau nha bạn

(vl-load-com)
(defun c:sz (/ ss lst h xlist ent1 x1 ent2 x2 lst1 ent i j nb1 nb2 nb3 nb4 txt1 txt2 txt3 txt4 x y z)
 (prompt "\nQu\U+00E9t ch\U+1ECDn khu v\U+1EF1c ch\U+1EE9a Text")
  (setq ss  (acet-ss-to-list (ssget (list (cons 0 "TEXT")))))
  (mapcar ' (lambda (x) (setq ent (entget x))	(setq ent (subst (cons 73 2) (assoc 73 ent) ent))    (setq ent (subst (cons 72 0) (assoc 72 ent) ent))
	     (entmod ent)) ss)
  (setq lst (list)
	h (* 2.5 (cdr (assoc 40 (entget (nth 0 ss)))))
	xlist (list))
(mapcar '(lambda (ent1)	   
    (setq x1 (fix (/ (cadr (assoc 10 (entget ent1))) h)))
    (if (not (vl-position x1 xlist)) (progn
	(setq xlist (append xlist (list x1)))
    (setq lst1 (list)) 
      (mapcar ' (lambda (ent2)
      (setq x2 (fix (/ (cadr (assoc 10 (entget ent2))) h)))   
      (if (= x1 x2) (progn
	(setq lst1 (append lst1 (list ent2)))
	))
      ) ss)
    (setq lst (append lst (list lst1)))
	))
    ) ss)
  (if (and (= (length lst) 4)
	   (= (length (nth 0 lst)) (length (nth 2 lst)))
	   (= (length (nth 1 lst)) (length (nth 3 lst))) )
	      (progn
(foreach ent ss
    (vla-put-color (vlax-ename->vla-object ent) 1))
  (setq lst (vl-sort lst ' (lambda (x y) (< (cadr (assoc 10 (entget (nth 0 x)))) (cadr (assoc 10 (entget (nth 0 y))))))))
(mapcar '(lambda z) (setq z (vl-sort z '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))))) lst)
(setq i 0)
(while (setq nb1 (nth i (nth 0 lst)))
  (setq txt1 (cdr (assoc 1 (entget nb1))))
  (setq nb2 (nth i (nth 1 lst))
	txt2 (cdr (assoc 1 (entget nb2))))
  (if (vl-string-search "x" txt2) (progn
(setq	txt2 (Substr txt2 (+ (strlen (vl-string-right-trim "1234567890" txt2)) 1))
	)))
  (setq i (1+ i))	
  (setq j 0)
  (while (setq nb3 (nth j (nth 2 lst)))
    (setq txt3 (cdr (assoc 1 (entget nb3))))
    (setq nb4 (nth j (nth 3 lst))
	  txt4 (cdr (assoc 1 (entget nb4))))
    (if (vl-string-search "x" txt4) (progn
(setq	txt4 (Substr txt4 (+ (strlen (vl-string-right-trim "1234567890" txt4)) 1))
	)))
	 (setq j (1+ j))
    (if (and (= txt1 txt3)
	     (= txt2 txt4)) (progn
      (vla-put-color (vlax-ename->vla-object nb1) 2)
      (vla-put-color (vlax-ename->vla-object nb2) 2)
      (vla-put-color (vlax-ename->vla-object nb3) 2)
      (vla-put-color (vlax-ename->vla-object nb4) 2)
      )))
  )
  ) (alert "\nS\U+1ED1 c\U+1ED9t text kh\U+00F4ng \U+0111\U+00FAng ho\U+1EB7c s\U+1ED1 text t\U+01B0\U+01A1ng \U+1EE9ng v\U+1EDBi m\U+1ED7i c\U+1ED9t kh\U+00F4ng b\U+1EB1ng nhau!")
    )
(princ)
   )
  
  
  

Ở lisp này mình đã chỉnh kiểu text về Middle Left cho dễ nhìn, các điểm insertion không cách nhau quá xa thì oke

<<

 

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa...

>>

 

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa điện 3 pha A B C.

Nhưng mình đang luyện bài nên nếu bạn muốn thì code trên có thể nâng lên thành n pha :D

 

>>> Cảm ơn bác ndtnv đã chỉ điểm, mình học được khá nhiều từ bác !

;;;lisp danh so cot den
(defun c:SCD( / st str lst_pha i p vi_tri chu str1)
(vl-load-com)
(setq	#tu (NGT #tu "1" getstring "Tu chieu sang so")
		#lo (NGT #lo "1" getstring "Lo so")
		#st (NGT #st 1 getint "STT cot dau tien")
		st (1- #st)
		str (strcat "TCS" #tu "/L" #lo "/")
		)
;;;========+++++++++++
;Thay doi, them bot lst_pha o day:
(setq lst_pha '("A" "B" "C"))
;;;=======++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
(defun add_space (str) (strcat str " "))
(defun add_solidus (str) (strcat str "/"))
(initget 1 (strcat (apply 'strcat (mapcar 'add_space (reverse (cdr (reverse lst_pha))))) (last lst_pha)))
(setq #pha (NGT #pha "A" getkword (strcat "Pha dau tien ")))
;;;========
(setq #text_h (NGT #text_h 2.5 getint "Chieu cao chu"))
(setq i -1)
(while (setq p (getpoint "\nPick: "))
	(setq i (1+ i)
		  st (1+ st)
		  vi_tri (vl-position (strcase #pha) lst_pha)
		  chu (nth (rem (+ i vi_tri) (length lst_pha)) lst_pha)
		  str1 (strcat str (itoa st) chu)
		  )
	(MakeText p str1 #text_h 0 "L" nil nil 2 nil)
)	;while
)
;;;==================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;;;=================================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= 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)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================

Cám ơn bạn, về mặt ứng dụng, đối với  mình như này là quá ổn rồi! Mặc dù pha mình chỉ sử dụng chỉ là A, B, C, không bao giờ hơn, nên nếu bạn muốn tối ưu hóa lisp như góp ý của bạn ndtnv thì bạn có thể nghiên cứu thêm nhé J

<<

Download lisp

Filename: 388323_scd.lsp

Mình chỉ sửa theo các ý của "ro88" và "hoangkimioanh" thôi, lisp chạy ra chắc chưa được đẹp lắm. Đế hoàn thiện hơn 2 ban nên nhờ trực...

>>

Mình chỉ sửa theo các ý của "ro88" và "hoangkimioanh" thôi, lisp chạy ra chắc chưa được đẹp lắm. Đế hoàn thiện hơn 2 ban nên nhờ trực tiếp bác "ketxu" nhé. Đây là lisp đã sửa:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
 (setq p1 (polar p0 (dtr a) r))
 (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
 (setq	i 0
L nil
 )
 (vl-load-com)
 (repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
 )
 L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
 (setq i 0)
 (foreach pt Lst
(if (equal pt0 pt 0.001)
  (setq rt i))
(setq i (1+ i)))
 (append (append (member (nth rt Lst) Lst)
 	(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
 	(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
 (entmake (list (cons 0 "TEXT")
 	(cons 7 (getvar "textstyle"))
 	(cons 1 txt)
 	(cons 10 p)
 	(cons 11 p)
 	(cons 40 h)
 	(cons 72 1)
 	(cons 73 2)
 	(if k (cons 51 (DTR 18)) (cons 51 0))
)
 )
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
 (setq SS (ssadd))
 (ssadd e SS)
 (while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
 SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1	(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
 (if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
 )
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i  0
 )
 (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i  0
 )
 (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn ntp)
 (setvar "cmdecho" 0)
;;;New layer check
 (newlayer "kichthuoc" 7 "continuous" "default")
 (newlayer "stt" 1 "continuous" "default")
 (newlayer "bangtd" 7 "continuous" "default")
;;;GET TEXT HEIGHT
 (if (not h0)  (setq h0 1))
 (setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
 (if (not h)  (setq h h0)  (setq h0 h))
;;;GET DECIMAL PRECISION
 (if (not ntp0)  (setq ntp0 2))
 (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
 (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))
;;;GET CIRCLE RADIUS
 (if (not cr0)  (setq cr0 0.3))
 (setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
 (if cr (setq cr0 cr))

;;;PICK & BASE POINT
 (initget "Y")
 (setq save (getkword "\nBan co muon luu file? < Y / Enter for No >:"))

 (setq oldos (getvar "osmode")
pdau (getpoint "\nPick diem dau tien (so thu tu = 1): " )
 )

 ;(while pdau
(setq p (getpoint "\nPick 1 diem giua mien kin:")
 	pvL nil pvL1 nil)
(command "boundary" p "")
(setq et (entlast)
  	pvL1 (reverse (getvert et)))
(redraw et 3)
(setq p00 (getpoint "\nDiem dat Bang TDGR:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq  p0 p00
   	p01  (polar p00 (* 1.5 pi) (* h 3))  
   	pvL  (relist pdau pvL1)
   	n	(length pvL)
   	p02	(polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
)
(setvar "osmode" 0)
;;;HEADER
 (setvar "CLAYER" "bangtd")
 (linepx p0 (* 32 h))
 (command "copy" "L" "" "m" p00 p01 p02 "")
 (linepy p0 (- (distance p0 p02)))
 (command "copy" "L" "" "m"  p0
(list (+ (car p0) (* 4 h)) (cadr p0))
(list (+ (car p0) (* 14 h)) (cadr p0))
(list (+ (car p0) (* 24 h)) (cadr p0))
(list (+ (car p0) (* 32 h)) (cadr p0))
"")
 (setq Lkqua nil)
 (wtxtMC "Bang toa do cac dinh thua dat"
 	(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
 	(* 1.2 h) nil)
 (txt1 (setq Lkq (list "TT" "X (m)" "Y (m)" "S (m)")))
 (setq Lkqua (append Lkqua (list Lkq)))
 (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
;;;MAKE RECORDS
 (if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
 (setq	j  0
pt nil)
 (repeat n
(setq
  pv  (nth j pvL)
  num (itoa (1+ j))
num (strcat "M" num)
)
(if	pt
  (setq S (rtos (distance pt pv) 2 ntp))
  (setq S "")
)
(setq
  txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
  Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
(setq pt pv)
(setq j (1+ j))
(if	(= j (- n 1))  (setq j 0))
 )
;;;MAKE BLOCK
 (setq ss (collect1 et))
 (setq bn "1")
 (while (tblsearch "block" bn)
(setq bn (itoa (1+ (atoi bn))))
 )
 (command "block" bn p00 ss "")
 (command "insert" bn p00 "" "" "")
;;;WRITE POINT NAME
 (setvar "CLAYER" "stt")
 (setq j 0)
 (repeat (1- n)
(setq
  pv  (nth j pvL)
  num (itoa (1+ j))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "erase" vtron "")
(setq j (1+ j))
 )
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
 ;;; )
 (setvar "cmdecho" 1)
 (princ)
)
;;;-------------------------------------------------------------------------------
(defun savef()
 (if save
(progn
  (setq file (open (setq tenfile (strcat (getvar "dwgprefix")
(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
  (foreach line Lkqua
(setq line1 "")
(foreach it line
 	(setq line1 (strcat line1 " " it)))
(write-line line1 file)
  )
  (close file)
  (princ (strcat "\nDa luu thanh file " tenfile))
)
 )
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
 (if (/= p nil)
(entmake (list
   	(cons 0 "TEXT")
   	(cons 62 2)
   	(cons 10 p)
   	(cons 40 h)
   	(cons 1 S)
   	(cons 50 a )
   	(cons 41 0.7)
   	(cons 7 (getvar "textstyle"))
   	(cons 72 1)
   	(cons 11 p)
   	(cons 73 3)
 	)
)
 )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
 (if (/= p nil)
(entmake (list
   	(cons 0 "TEXT")
   	(cons 62 2)
   	(cons 10 p)
   	(cons 40 h)
   	(cons 1 S)
   	(cons 50 a )
   	(cons 41 0.7)
   	(cons 7 (getvar "textstyle"))
   	(cons 72 1)
   	(cons 11 p)
   	(cons 73 1)
 	)
)
 )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
 (setq
i	0  
k	(1- (length pvL))
 )
 (repeat k
(setq
  p1   (nth i pvL)
  p2   (nth (+ i 1) pvL)
  dist (distance p1 p2)
  rad  (angle p1 p2)
  x_mp (* (+ (car p1) (car p2)) 0.5)
  y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
  mp   (list x_mp y_mp)
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
  (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
  (progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
  )
  (Text_canh_BCA (rtos dist 2 2) mp rad)
)
(command "DIMALIGNED" p1 p2 mp)
(setq i (1+ i))
 )
 ;; repeat k;
)
;;;--------------------------

 

 

Cảm ơn VoHoan nhiều nhé.

cái chạy Thuận Nghịch thì ok roài.nhưng bạn có thể hoán đổi tọa độ cột X sang Y và thêm những đường line chia mỗi hàng ra như bản vẽ mình đã up ở trên nhé

và hatch những nút tròn ở mỗi đỉnh thửa lun nhé

Nếu được thì bạn có thể đổi tên bảng tọa độ giống như trong bản vẽ lun thì ok.

Thanks rất nhiều.

mình up lại bản vẽ nhé

 

 

 

http://www.cadviet.com/upfiles/3/73751_ban_ke_toa_do_2.dwg

<<

 

S­ửa lại cho bạn đây:

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

 

S­ửa lại cho bạn đây:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
  (setq p1 (polar p0 (dtr a) r))
  (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
  (setq	i 0
	L nil
  )
  (vl-load-com)
  (repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
  )
  L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
  (setq i 0)
  (foreach pt Lst
(if (equal pt0 pt 0.001)
   (setq rt i))
(setq i (1+ i)))
  (append (append (member (nth rt Lst) Lst)
  	(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
  	(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
	(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
  (entmake (list (cons 0 "TEXT")
  	(cons 7 (getvar "textstyle"))
  	(cons 1 txt)
  	(cons 10 p)
  	(cons 11 p)
  	(cons 40 h)
  	(cons 72 1)
  	(cons 73 2)
  	(if k (cons 51 (DTR 18)) (cons 51 0))
	)
  )
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
  (setq SS (ssadd))
  (ssadd e SS)
  (while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
  SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1	(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
  (if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
  )
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
  (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i  0
  )
  (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
  )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
  (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i  0
  )
  (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
  )
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ h p et p0 p00 p01 p02 pt pvL pvL1 n j pv num txtL ss bn ntp p11 p12 p13 p14)
  (setvar "cmdecho" 0)
;;;New layer check
  (newlayer "kichthuoc" 7 "continuous" "default")
  (newlayer "stt" 1 "continuous" "default")
  (newlayer "bangtd" 7 "continuous" "default")
;;;GET TEXT HEIGHT
  (if (not h0)  (setq h0 1))
  (setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
  (if (not h)  (setq h h0)  (setq h0 h))
;;;GET DECIMAL PRECISION
  (if (not ntp0)  (setq ntp0 2))
  (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
  (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))
;;;GET CIRCLE RADIUS
  (if (not cr0)  (setq cr0 0.3))
  (setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
  (if cr (setq cr0 cr))

;;;PICK & BASE POINT
  (initget "Y")
  (setq save (getkword "\nBan co muon luu file? < Y / Enter for No >:"))

  (setq oldos (getvar "osmode")
	pdau (getpoint "\nPick diem dau tien (so thu tu = M1): " )
  ) 

  ;(while pdau
(setq p (getpoint "\nPick 1 diem giua mien kin:")
          	pvL nil pvL1 nil)
(command "boundary" p "")
(setq et (entlast)
         	pvL1 (reverse (getvert et))) 
(redraw et 3) 
(setq p00 (getpoint "\nDiem dat Bang TDGR:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq  p0 p00
    	p01  (polar p00 (* 1.5 pi) (* h 3))   
    	pvL  (relist pdau pvL1)
    	n	(length pvL)
    	p02	(polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
) 
(setvar "osmode" 0)
;;;HEADER
  (setvar "CLAYER" "bangtd")
  (linepx p0 (* 32 h))
  (command "copy" "L" "" "m" p00 p01 "")
  (setq Lkqua nil)
  (command "style" "CadViet" ".VnArialH" "" "" "" "" "")
  (wtxtMC "B¶ng kª täa ®é vµ kho¶ng c¸ch"
  	(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 4 h))
  	(* 1.2 h) nil)
  (wtxtMC "HÖ täa ®é VN - 2000"
  	(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
  	(* 1.2 h) nil)
  (txt1 (setq Lkq (list "TT" "Y (m)" "X (m)" "S (m)")))
  (setq Lkqua (append Lkqua (list Lkq)))
  (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
;;;MAKE RECORDS
  (if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
  (setq	j  0
	pt nil)
  (repeat n
(setq
   pv  (nth j pvL)
   num (itoa (1+ j))
num (strcat "M" num)
)
(if	pt
   (setq S (rtos (distance pt pv) 2 ntp))
   (setq S "")
)
(setq
   txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
   Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq p11 (polar p0 (* 1.5 pi) (* 2.5 h)))
(setq P12 (polar p11 0 (* 25 h)))
(setq P13 (polar p11 0 (* 31 h)))
(setq P14 (polar p11 0 (* 32 h)))
(command "LINE" p11 p12 "")
(command "LINE" p13 p14 "")
(setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
(setq pt pv)
(setq j (1+ j))
(if	(= j (- n 1))  (setq j 0))
  )
  (command "LINE" p11 p14 "")
  (linepy p00 (- (distance p00 (polar p0 (* 1.5 pi) (* 0.5 h)) )))
  (command "copy" "L" "" "m"  p0
	(list (+ (car p0) (* 4 h)) (cadr p0))
	(list (+ (car p0) (* 14 h)) (cadr p0))
	(list (+ (car p0) (* 24 h)) (cadr p0))
	(list (+ (car p0) (* 32 h)) (cadr p0))
	"")
;;;WRITE POINT NAME
  (setvar "CLAYER" "stt")
  (setq j 0)
  (repeat (1- n)
(setq
   pv  (nth j pvL)
   num (itoa (1+ j))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "HATCH" "solid" "L" "")
(command "erase" vtron "")
(setq j (1+ j))
  )
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh) 
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
  ;;; ) 
  (setvar "cmdecho" 1)
  (princ)
)
;;;-------------------------------------------------------------------------------
(defun savef() 
  (if save
(progn
   (setq file (open (setq tenfile (strcat (getvar "dwgprefix")
 	(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
   (foreach line Lkqua
	(setq line1 "")
	(foreach it line
  	(setq line1 (strcat line1 " " it)))
	(write-line line1 file)
   )
   (close file)
   (princ (strcat "\nDa luu thanh file " tenfile))
)
  )
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
  (if (/= p nil)
(entmake (list
    	(cons 0 "TEXT")
    	(cons 62 2)
    	(cons 10 p)
    	(cons 40 h)
    	(cons 1 S)
    	(cons 50 a )
    	(cons 41 0.7)
    	(cons 7 (getvar "textstyle"))
    	(cons 72 1)
    	(cons 11 p)
    	(cons 73 3)
  	)
)
  )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
  (if (/= p nil)
(entmake (list
    	(cons 0 "TEXT")
    	(cons 62 2)
    	(cons 10 p)
    	(cons 40 h)
    	(cons 1 S)
    	(cons 50 a )
    	(cons 41 0.7)
    	(cons 7 (getvar "textstyle"))
    	(cons 72 1)
    	(cons 11 p)
    	(cons 73 1)
  	)
)
  )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp mp1)
  (setq
i	0  
k	(1- (length pvL))
  )
  (repeat k
(setq
   p1   (nth i pvL)
   p2   (nth (+ i 1) pvL)
   dist (distance p1 p2)
   rad  (angle p1 p2)
   x_mp (* (+ (car p1) (car p2)) 0.5)
   y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
   mp   (list x_mp y_mp)
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
   (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
   (progn
	(setq rad (+ rad pi))
	;(Text_canh_TCA (rtos dist 2 2) mp rad)
)
   ;(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq mp1 (polar mp (angle p mp) (* 2 h)) )
(command "DIMALIGNED" p1 p2 mp1)
(setq i (1+ i))
  )
  ;; repeat k;
)
;;;--------------------------

các bác ơi, cho em hỏi tí là muốn sửa để phần toạ độ XY có 4 số sau dấu phẩy (,) thì làm thế nào ạ! cả thay đổi cột YX thành XY nữa! cảm ơn các bác

<<

16 giờ trước, Han Tinh đã nói:

Sau khi dùng thử thì mình có góp...

>>

16 giờ trước, Han Tinh đã nói:

Sau khi dùng thử thì mình có góp ý này:

- Khi số dòng 2 dãy text khác nhau thì nó báo lỗi, trường hợp này số dòng nào dư thì bạn cho nó về màu đỏ luôn nha (vì có khi khách hàng thống kê thiếu hoặc mình thống kê thiếu)

- Không biết bị lỗi gì khi dùng lệnh (file đính kèm: các text cần thống kê và file đã thống kê)

Bạn xem qua giúp mình với

CAC TEXT CAN SO SANH.dwg

MAT BANG CAN THONG KE.dwg

(vl-load-com)
(defun c:sz (/ xx lstx m n ss lst h xlist ent1 x1 ent2 x2 lst1 ent i j nb1 nb2 nb3 nb4 txt1 txt2 txt3 txt4 x y z)
 (prompt "\nQu\U+00E9t ch\U+1ECDn khu v\U+1EF1c ch\U+1EE9a Text")
  (setq ss  (acet-ss-to-list (ssget (list (cons 0 "TEXT")))))
  (setq lst (list)
	h (* 2.5 (cdr (assoc 40 (entget (nth 0 ss)))))
	xlist (list)
	m 0)
(while (setq ent1 (nth m ss))
(setq xx (cadr (assoc 10 (entget ent1))))
 (setq n 0)
(if (> (length xlist) 0) (progn
  (while (setq lstx (nth n xlist))
    (if (and (< xx (cadr lstx))
	     (> xx (car lstx))) (progn (setq m (1+ m))
				  (setq n 100)) (setq n (1+ n)))
    )))
 (if (/= n 100) (progn
(setq m (1+ m)) 
(setq x1 (fix (+ (cadr (assoc 10 (entget ent1))) h)))
(setq x2 (fix (- (cadr (assoc 10 (entget ent1))) h)))
 (setq xlist (append xlist (list (list x2 x1))))
(prompt (strcat "\n" (rtos x2 2 2) "-" (rtos x1 2 2)))
    (setq lst1 (list)) 
      (mapcar ' (lambda (ent2)
      (setq xx (cadr (assoc 10 (entget ent2))))   
      (if (and (< xx x1)
	     (> xx x2)) (progn
	(setq lst1 (append lst1 (list ent2)))
	))
      ) ss)
))
    (setq lst (append lst (list lst1)))
)
  (setq lst (vl-sort lst ' (lambda (x y) (< (cadr (assoc 10 (entget (car x)))) (cadr (assoc 10 (entget (car y))))))))
  (if (and (= (length lst) 4)
	   (= (length (nth 0 lst)) (length (nth 1 lst)))
	   (= (length (nth 2 lst)) (length (nth 3 lst))) )
	      (progn
(foreach ent ss
    (vla-put-color (vlax-ename->vla-object ent) 1))
(mapcar '(lambda (z) (setq z (vl-sort z '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))) lst)
(setq i 0)
(while (setq nb1 (nth i (nth 0 lst)))
  (setq txt1 (cdr (assoc 1 (entget nb1))))
  (setq nb2 (nth i (nth 1 lst))
	txt2 (cdr (assoc 1 (entget nb2))))
  (if (vl-string-search "x" txt2) (progn
(setq	txt2 (Substr txt2 (+ (strlen (vl-string-right-trim "1234567890" txt2)) 1))
	)))
  (setq i (1+ i))	
  (setq j 0)
  (while (setq nb3 (nth j (nth 2 lst)))
    (setq txt3 (cdr (assoc 1 (entget nb3))))
    (setq nb4 (nth j (nth 3 lst))
	  txt4 (cdr (assoc 1 (entget nb4))))
    (if (vl-string-search "x" txt4) (progn
(setq	txt4 (Substr txt4 (+ (strlen (vl-string-right-trim "1234567890" txt4)) 1))
	)))
	 (setq j (1+ j))
    (if (and (= txt1 txt3)
	     (= txt2 txt4)) (progn
      (vla-put-color (vlax-ename->vla-object nb1) 2)
      (vla-put-color (vlax-ename->vla-object nb2) 2)
      (vla-put-color (vlax-ename->vla-object nb3) 2)
      (vla-put-color (vlax-ename->vla-object nb4) 2)
      )))
  )
  )
      (alert "\nS\U+1ED1 c\U+1ED9t text kh\U+00F4ng \U+0111\U+00FAng ho\U+1EB7c s\U+1ED1 text t\U+01B0\U+01A1ng \U+1EE9ng v\U+1EDBi m\U+1ED7i c\U+1ED9t kh\U+00F4ng b\U+1EB1ng nhau!")
    )

   )
  
  
  

Sorry bạn, không kiểm tra kỹ file ban đầu của bạn đặt số text  2 hàng bằng nhau mà chênh chiều cao nên cái hàm so sánh bị sai mà không biết, đã sửa lại cho bạn.

<<

Đoan lisp này mình viết để bo cong các polyline.

(defun C:VBK(/ )
(command "undo" "be")
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(while ;(setq dtuong1 (car (entsel "\nChon doi tuong 1")))
(or (and bkinh (or (= (type bkinh) 'int) (= (type bkinh) 'real))) (setq bkinh 5.00))
(setq bkinh (cond ((getreal (strcat "\nNhap ban kinh cong (m)...
>>

Đoan lisp này mình viết để bo cong các polyline.

(defun C:VBK(/ )
(command "undo" "be")
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(while ;(setq dtuong1 (car (entsel "\nChon doi tuong 1")))
(or (and bkinh (or (= (type bkinh) 'int) (= (type bkinh) 'real))) (setq bkinh 5.00))
(setq bkinh (cond ((getreal (strcat "\nNhap ban kinh cong (m) <" (rtos bkinh 2 2) ">: "))) (bkinh)))
;(setq dtuong2 (car (entsel "\nChon doi tuong 2")))
(command "FILLET" "R" bkinh)
(command "FILLET" pause pause)
;(dobk (entlast))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
(command "undo" "end")
(princ)
)
;(command 

Bây giờ mình muốn sau khi bo xong nó điền luôn bán kính vào luôn.

Mong mọi người giúp đỡ.

Thân!!!

10 phút trước, Black_Cat_ đã nói:

dạ em biết rồi ạ em sẽ xóa...

>>

10 phút trước, Black_Cat_ đã nói:

dạ em biết rồi ạ em sẽ xóa bài đăng cũ

(defun c:cl (/ ss ent str lst dc x)
  (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "TEXT"))))) (progn
  (foreach ent ss
    (setq str (vla-get-textstring (vlax-ename->vla-object ent)))
    (setq lst (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
    (setq dc "false")
    (mapcar '(lambda (x) (if (vl-string-search x str) (setq dc "true"))) lst)
    (if (= dc "true")
      (vla-put-layer (vlax-ename->vla-object ent) "Layer Dia Chi")
      (vla-put-layer (vlax-ename->vla-object ent) "Layer Chu Ho")
      )))
    ))

Nhắc bạn thôi mà chứ có bảo xóa đâu ^^ 

<<

(defun c:mm (/ getlst ss n ent osm lst2 lst ent1 pt1 pt2 tt p1 i x y)
  (defun getlst (p1 ent /...
>>

(defun c:mm (/ getlst ss n ent osm lst2 lst ent1 pt1 pt2 tt p1 i x y)
  (defun getlst (p1 ent / p2 dis)
      (setq p2 (vlax-curve-getClosestPointToProjection ent p1 (list 0 1 0) ))
      (setq dis (distance p1 p2))
      (list dis p1 p2)	)
  (if(setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE,LINE,CIRCLE,ARC"))))) (progn (setq n 0)
(mapcar '(lambda (x) (if (= (cdr (assoc 0 (entget x))) "LWPOLYLINE") (if (> (vlax-curve-getendparam x) n) (progn(setq ent x) (setq n (vlax-curve-getendparam x)))))) ss)
  (setq lst2 (list))
  (Mapcar '(lambda (ent1)
    (setq lst (list))
    (if (= (cdr (assoc 0 (entget ent1))) "LINE") (progn
	(setq pt1 (vlax-curve-getpointatparam ent1 (vlax-curve-getstartparam ent1)))
	(setq pt2 (vlax-curve-getpointatparam ent1 (vlax-curve-getendparam ent1)))
	(foreach p1 (list pt1 pt2)
        (setq lst (append lst (list (getlst p1 ent))))
	  )))
    (if (= (cdr (assoc 0 (entget ent1))) "LWPOLYLINE")(progn
    (setq i (vlax-curve-getstartparam ent1))
    (while (setq p1 (vlax-curve-getpointatparam ent1 i))
      (setq i (1+ i))
      (setq lst (append lst (list (getlst p1 ent))))
      )))
    (if (wcmatch (setq tt (cdr (assoc 0 (entget ent1)))) "ARC,CIRCLE") (progn
    (if (= tt "CIRCLE") (setq p  (vla-get-circumference (vlax-ename->vla-object ent1))))
    (if (= tt "ARC")  (setq p  (vla-get-arclength (vlax-ename->vla-object ent1))))
    (setq  i 0)
    (while (< i p)
      (setq p1 (vlax-curve-getpointatdist ent1 i))
      (setq i (+ 0.1 i))
      (setq lst (append lst (list (getlst p1 ent))))
      )))
    (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y)))))
    (setq lst2 (append lst2 (list (list (vlax-ename->vla-object ent1) (cadr (car lst)) (caddr (car lst))))))
    ) ss)
  (Mapcar '(lambda (lst)(vla-Move (car lst) (vlax-3d-point (cadr lst)) (vlax-3d-point (caddr lst)))) lst2)
  ))
  (princ))

Đối với ARC và CIRCLE mới lấy được tiếp tuyến tại điểm có độ chính xác 0.1, k biết các bác có ý tưởng nào hay hơn về vấn đề này ? 

(defun c:mm (/ getlst ss n ent osm lst2 lst ent1 pt1 pt2 tt p1 i x y ddau dcuoi ang pt r)
  (defun getlst (p1 ent 
>>

(defun c:mm (/ getlst ss n ent osm lst2 lst ent1 pt1 pt2 tt p1 i x y ddau dcuoi ang pt r)
  (defun getlst (p1 ent / p2 dis)
      (setq p2 (vlax-curve-getClosestPointToProjection ent p1 (list 0 1 0) nil ))
      (setq dis (distance p1 p2))
      (list dis p1 p2)	)
  (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE,LINE,CIRCLE,ARC"))))) (progn (setq n 0)
(mapcar '(lambda (x) (if (= (cdr (assoc 0 (entget x))) "LWPOLYLINE") (if (> (vlax-curve-getendparam x) n) (progn(setq ent x) (setq n (vlax-curve-getendparam x)))))) ss)
  (setq lst2 (list))
  (Mapcar '(lambda (ent1)
    (setq lst (list))
    (if (= (cdr (assoc 0 (entget ent1))) "LINE") (progn
(mapcar '(lambda (x) (setq lst (append lst (list (getlst x ent))))) (list (vlax-curve-getpointatparam ent1 (vlax-curve-getstartparam ent1))
										  (vlax-curve-getpointatparam ent1 (vlax-curve-getendparam ent1))))
      ))
    (if (= (cdr (assoc 0 (entget ent1))) "LWPOLYLINE")(progn
    (setq i (vlax-curve-getstartparam ent1))
    (while (setq p1 (vlax-curve-getpointatparam ent1 i))
      (setq i (1+ i))
      (setq lst (append lst (list (getlst p1 ent))))
      ))) 
  (if (wcmatch (setq tt (cdr (assoc 0 (entget ent1)))) "ARC,CIRCLE") (progn
    (setq ddau (vlax-curve-getstartparam ent)
	  dcuoi (vlax-curve-getendparam ent))
    (while (< ddau dcuoi)
      (setq ang (angle (vlax-curve-getpointatparam ent ddau) (vlax-curve-getpointatparam ent (1+ ddau)))
	    ddau (1+ ddau)
	    pt (cdr (assoc 10 (entget ent1)))
	    r (cdr (assoc 40 (entget ent1))))
      (setq p1 (polar pt (+ ang (/ pi 2)) r))
      (if (vlax-curve-getdistatpoint ent1 p1)
      (setq lst (append lst (list (getlst p1 ent)))))
      (setq p1 (polar pt (+ ang (* pi 1.5)) r))
      (if (vlax-curve-getdistatpoint ent1 p1)
      (setq lst (append lst (list (getlst p1 ent)))))
      )
    (if (= tt "ARC") (progn
(mapcar '(lambda (x) (setq lst (append lst (list (getlst x ent))))) (list (vlax-curve-getpointatparam ent1 (vlax-curve-getstartparam ent1))
										  (vlax-curve-getpointatparam ent1 (vlax-curve-getendparam ent1))))
	  ))	       
   ))
    (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y)))))
    (setq lst2 (append lst2 (list (list (vlax-ename->vla-object ent1) (cadr (car lst)) (caddr (car lst))))))
    ) ss)
  (Mapcar '(lambda (lst) (if (= (car (cadr lst)) (car (caddr lst)))(vla-Move (car lst) (vlax-3d-point (cadr lst)) (vlax-3d-point (caddr lst))))) lst2)
  ))
  (princ))

13 phút trước, ngokiet đã nói:

Hình như bác không xem kỹ. nếu 2...

>>

13 phút trước, ngokiet đã nói:

Hình như bác không xem kỹ. nếu 2 line hay 2 arc thì mới có entlast đễ ghi kích thước thì dễ rồi. 2 polyline thì khó.

Vấn đề của mình là ở chỗ này.

Sau khi filett xong nó trở thành 1 đối tượng làm sao để chọn đối tượng đó (mình có lisp đo đường polyline rồi)

Lisp đo đường polyline có đường cong:

(defun c:DSE (/ h lt acadobj ddat e s dis doc i modelspace obj ang ang1 ang2 m etype LM:BulgeCenter)

(defun LM:BulgeCenter (p1 p2 B)

(polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan B)))) (/ (* (distance p1 p2) (1+ (* b B))) 4 B)))

(defun etype (e / x)

(or (setq x (entget e)) (and (setq x (entget (entdel e))) (entdel e)))

(cdr (assoc 0 x)))

(setq acadObj (vlax-get-acad-object))

(setq doc (vla-get-activedocument acadObj))

(setq modelSpace (vla-get-modelspace doc))

;(setq i 0)
(setq h (getvar "Dimtxt"))
(setq lt (getvar "Dimscale"))
 (if  (setq	j -1
		s (ssget '((0 . "*POLYLINE")))
       )
(repeat (sslength s)
	(setq e	  (ssname s (setq j (1+ j))))
(setq i 0)
(if (wcmatch (etype e) "*POLYLINE")

(if (setq ddat (getpoint (vlax-curve-getstartpoint e) "\nPhia dat Dim (Pick diem):"))

(progn 
(setq ang1 (angle (vlax-curve-getstartpoint e) (vlax-curve-getpointatparam e (1+ i)))

ang2 (angle (vlax-curve-getstartpoint e) ddat)

ang (- ang2 ang1))

(cond ((= ang1 0)

(cond ((< ang2 (* pi 1.0)) (setq m -2.0))

(t (setq m +2.0))))

((= ang1 (* pi 0.5))

(cond ((< ang2 (* pi 0.5)) (setq m +2.0))

((> ang2 (* pi 1.5)) (setq m +2.0))

(t (setq m -2.0))))

((= ang1 (* pi 1.0))

(cond ((< ang2 (* pi 1.0)) (setq m +2.0))

((> ang2 (* pi 2.0)) (setq m -2.0))

(t (setq m -2.0))))

((= ang1 (* pi 1.5))

(cond ((< ang2 (* pi 0.5)) (setq m -2.0))

((< ang2 (* pi 1.5)) (setq m +2.0))

((> ang2 (* pi 1.5)) (setq m -2.0))

(t (setq m -2.0))))

(t

(cond ((< ang (* pi 0.0)) (setq m +2.0))

((< ang (* pi 1.0)) (setq m -2.0))

((< ang (* pi 2.0)) (setq m +2.0)))))

(setq obj (vlax-ename->vla-object e))

;(setq dis (distance ddat (vlax-curve-getstartpoint e)))
(setq dis (* (* h lt) 2.5))
(repeat (fix (vlax-curve-getendparam e))

(if (= 0 (vla-getbulge obj i))

(vla-adddimaligned modelSpace

(vlax-3d-point (vlax-curve-getpointatparam e i))

(vlax-3d-point (vlax-curve-getpointatparam e (1+ i)))

(vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))

(- (angle '(0 0 0) (vlax-curve-getfirstderiv e (+ i 0.5))) (/ pi m))

dis)))

(progn 
(vla-adddimarc modelSpace

(vlax-3d-point (LM:BulgeCenter (vlax-curve-getpointatparam e i)

(vlax-curve-getpointatparam e (1+ i))

(vla-getbulge obj i)))

(vlax-3d-point (vlax-curve-getpointatparam e i))

(vlax-3d-point (vlax-curve-getpointatparam e (1+ i)))

(vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))

(- (angle '(0 0 0) (vlax-curve-getfirstderiv e (+ i 0.5))) (/ pi m))

dis)))

(vla-adddimradial modelSpace

(vlax-3d-point (LM:BulgeCenter (vlax-curve-getpointatparam e i)

(vlax-curve-getpointatparam e (1+ i))

(vla-getbulge obj i)))

(vlax-3d-point (vlax-curve-getpointatparam e (+ i 0.5)))

-0.5))) ;if

(setq i (1+ i))) ;Repeat

) ;progn

) ;if
)
); repeat
) ;if

(princ))

 

<<

1 giờ trước, CadExTools đã nói:

Đối tượng PLine 1 có Ename +...

>>

1 giờ trước, CadExTools đã nói:

Đối tượng PLine 1 có Ename + số đỉnh

Đối tượng Pline 2 cũng có Ename và số đỉnh.

Sau khi Fillet xong thì nếu thành công thì đối tượng tạo thành sẽ có Ename là 1 trong 2 thằng đó (Ktra xem đối tượng nào còn TỒN TẠI) -> Bắt đối tượng đó thông qua Ename bên trên, dựa vào số đỉnh ta lại suy ra được vị trí của cái cung tròn đó.

Tại hạ có hạ kiến như thế, các hạ vui lòng thử

Lisp ở trên nó cho phép đo đường cong rồi nên không cần kiểm tra chỉ cần bắt được đối tượng polyline đưa vào thôi.

đây là lisp mình viết có thêm 1 bước là chọn đối tượng sau khi filett

(defun C:VBK(/ )
(command "undo" "be")
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(while ;(setq dtuong1 (car (entsel "\nChon doi tuong 1")))
(or (and bkinh (or (= (type bkinh) 'int) (= (type bkinh) 'real))) (setq bkinh 5.00))
(setq bkinh (cond ((getreal (strcat "\nNhap ban kinh cong (m) <" (rtos bkinh 2 2) ">: "))) (bkinh)))
(command "FILLET" "R" bkinh)
(command "FILLET" pause pause)
(dobk)
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
(command "undo" "end")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun dobk (/ acadobj doc i modelspace obj LM:BulgeCenter)
(defun LM:BulgeCenter (p1 p2 B)
(polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan B)))) (/ (* (distance p1 p2) (1+ (* b B))) 4 B)))
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-activedocument acadObj))
(setq modelSpace (vla-get-modelspace doc))
(setq i 0)
(setq e (car (entsel "\nChon cung dien ban kinh")))
(setq obj (vlax-ename->vla-object e))
(repeat (fix (vlax-curve-getendparam e))
(if (/= 0 (vla-getbulge obj i))
(vla-adddimradial modelSpace
(vlax-3d-point (LM:BulgeCenter (vlax-curve-getpointatparam e i)
(vlax-curve-getpointatparam e (1+ i))
(vla-getbulge obj i)))
(vlax-3d-point (vlax-curve-getpointatparam e (+ i 0.5)))
-0.5)
)
(setq i (1+ i))
)
(princ)
)

 

<<

Hi,

Mình nghĩ chèn text vào mỗi đỉnh nhanh hơn và đơn giản hơn. Bạn thử chạy lisp này. Thay tên lệnh Test nhé.

1. (defun c:test (/ pl vt_lst point z)
     (if (setq pl (car (entsel "\nChon 3Dpline: ")))
       (progn
         (if (eq (vla-get-ObjectName (vlax-ename->vla-object pl)) "AcDb3dPolyline")
   	(progn
   	  (setq vt_lst (vlax-get (vlax-ename->vla-object pl) 'Coordinates))
   	  (setq n 0)
   	  (repeat (/...
   >>

Hi,

Mình nghĩ chèn text vào mỗi đỉnh nhanh hơn và đơn giản hơn. Bạn thử chạy lisp này. Thay tên lệnh Test nhé.

1. (defun c:test (/ pl vt_lst point z)
     (if (setq pl (car (entsel "\nChon 3Dpline: ")))
       (progn
         (if (eq (vla-get-ObjectName (vlax-ename->vla-object pl)) "AcDb3dPolyline")
   	(progn
   	  (setq vt_lst (vlax-get (vlax-ename->vla-object pl) 'Coordinates))
   	  (setq n 0)
   	  (repeat (/ (length vt_lst) 3)
   	    (setq point (list (nth n vt_lst) (nth (1+ n) vt_lst) (nth (+ n 2) vt_lst)))
   	    (setq z (nth (+ n 2) vt_lst))
   	    (command "text"
   		     point
   		     20 ;<---thay doi chieu cao text
   		     0
   		     (rtos z 2 2)
   		     )
   	    (setq n (+ n 3))
   	    );repeat
   	  )
   	(princ "\nDoi tuong ban chon khong phai 3Dpolyline")
   	)
         );progn
       (princ "\nBan da khong chon doi tuong.")
       );if
     (princ)
     );defun
   

22 phút trước, minhmani đã nói:

Lý trình trên trắc ngang mình...

>>

22 phút trước, minhmani đã nói:

Lý trình trên trắc ngang mình không cần cộng lý trình bạn ơi :D. Mình dùng phần mềm nó sẽ tự nhảy, mình chỉ cần sửa cái trong Block thui :D

(defun c:ct (/ up ss i ent num att_set att_get tag val entatt)
     (defun att_set (ent tag val)
  (setq tag (strcase tag))
  (vl-some
    '(lambda (att)
       (if (= tag (strcase (vla-get-tagstring att)))
	 (progn (vla-put-textstring att val) val)
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    )
  )
    (defun att_get (entatt / att)
  (if entatt
    (mapcar '(lambda (att) (cons (vla-get-tagstring att) (vla-get-textstring att)))
	    (vlax-invoke (vlax-ename->vla-object entatt) 'getattributes)
	    )
    )
  )
  (or *up (setq *up 1))
  (or (setq up (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng t\U+0103ng (ho\U+1EB7c gi\U+1EA3m):< " (rtos *up 2) ">")))
      (setq up *up))
  (setq *up up)
  (if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "xs_def2"))))
  (progn
    (setq i 0)
    (while (setq ent (ssname ss i))
      (setq i (1+ i))
      (if (setq num (cdr (assoc "STATION" (att_get ent)))) (progn
   (setq num (+ (atof num) *up))
   (att_set ent "STATION" (rtos num 2))))
      )
    ))
  )
 

Áp dụng cho các bản vẽ có Block có tên "xs_def2"

Bạn có thể đổi tên block ở dòng (cons 2 "xs_def2")

<<

Sorry,

 

Lisp dưới đây sẽ khắc phục nhược điểm trên (lỗi xảy ra do layer hiện hành là sttkhu):

 

(setq
 lbd_textheight 20.0
...
>>

Sorry,

 

Lisp dưới đây sẽ khắc phục nhược điểm trên (lỗi xảy ra do layer hiện hành là sttkhu):

 

(setq
 lbd_textheight 20.0
 lbd_cellheight 50.0
 lbd_cellwidth	 200.0
 lbd_textlayer	 "sttkhu"
 lbd_kdlayer "vh"
)
(defun c:lbd ()
 (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)
 )
 (defun wtxt (txt p / sty d h)
   (entmake
     (list (cons 0 "TEXT")
    (cons 1 txt)
    (cons 10 p)
    (cons 40 lbd_textheight)
     )
   )
 )
 (defun dxf (code ent)
   (cdr (assoc code (entget ent)))
 )
 (defun findmother (p / mm)
   (foreach e lstm
     (if
(null
  (ssget "_F" (list p (dxf 10 e)) (list (cons 8 lbd_kdlayer)))
)
 (setq
   mother (dxf 1 e)
 )
     )
   )
   mother
 )
 (defun tinhdt	(ent / p)
   (setq p	(dxf 10 ent)
  elast	(entlast)
   )
   (command ".boundary" p "")
   (setq enew (entlast))
   (list
     (findmother p)
     (dxf 1 ent)
     (if (eq enew elast)
-1
(progn
  (command ".area" "ob" enew)
  (command ".erase" enew "")
  (getvar "area")
)
     )
   )
 )
 (setvar "clayer" "0")
 (setq
   p1	     (getpoint "\nGoc 1 cua mien chua ban do: ")
   p2	     (getcorner p1 "\nGoc 2 cua mien chua ban do: ")
   ss	     (ssget "_W"
	    p1
	    p2
	    (list (cons 0 "TEXT")
		  (cons 8 lbd_textlayer)
		  (cons 1 "")
	    )
     )
   lst	     (ss2ent ss)
   lstm     (ss2ent
       (ssget "_W"
	      p1
	      p2
	      (list (cons 0 "TEXT")
		    (cons 8 lbd_textlayer)
		    (cons 1 "~**")
	      )
       )
     )
   diemchen (getpoint "\nDiem chen ket qua: ")
 )
 (command ".layer" "off" lbd_textlayer "")
 (command ".zoom" p1 p2)
 (setq
   lst	(mapcar 'tinhdt lst)
 )
 (command ".layer" "on" lbd_textlayer "")
 (command ".zoom" "p")

 (setq	x0	  (car diemchen)
y0	  (cadr diemchen)
yht	  y0
lst	  (vl-sort lst
		  '(lambda (a b )
(if (= (car a) (car b ))
(()
)
)
lastindex (atoi (car (nth (1- (length lst)) lst)))
index	  1
lst	  (mapcar '(lambda (x) (cons (strcat (car x) (cadr x)) (caddr x)))
		  lst
	  )
 )
 (repeat lastindex
   (wtxt (itoa index) (list x0 yht))
   (setq xht x0
  part 97
   )

   (repeat 5
     (setq xht	 (+ xht lbd_cellwidth)
    gt	 (if (setq tmp (assoc (strcat (itoa index) (chr part)) lst))
	   (if (		     "__err__"
	     (rtos (cdr tmp) 2 2)
	   )
	   "_______"
	 )
    part (1+ part)
     )
     (wtxt gt (list xht yht))
   )
   (setq yht	(- yht lbd_cellheight)
  index	(1+ index)
   )
 )
 (princ)
)

Tue_NV nghĩ rằng "giám thị" cần giải thích cho "thí sinh" hiểu là Lisp Chỉ nhận chữ a, b, c, d, e thường chứ không phải là chữ hoa :cheers:

Nếu là chữ hoa thì Lisp chạy không đúng kết quả ngay

Do đó trước khi chạy Lisp phải chuyển chữ hoa thành chữ thường hoặc Có thể bác Hoành chỉnh lại chổ này 1 chút cho đúng với mọi trường hợp.

 

@Bác Hoành : Bác vui lòng cho Tue_NV hỏi thêm : số -1 trong đoạn Code tính diện tích này có nghĩa là gì? Em chưa hiểu chổ này lắm. Cảm ơn bác nhiều :cheers:

 

(defun tinhdt (ent / p)

(setq p (dxf 10 ent)

elast (entlast)

)

(command ".boundary" p "")

(setq enew (entlast))

(list

(findmother p)

(dxf 1 ent)

(if (eq enew elast)

-1

(progn

(command ".area" "ob" enew)

(command ".erase" enew "")

(getvar "area")

)

)

)

)

<<

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

Chào các anh em có file cad có...

>>

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

Chào các anh em có file cad có text là : T 145/185.25 thì trong đó T là mã còn 145 là số thửa , còn sau dấu / là diện tích viết liền cùng một text, giờ em muốn lấy riêng số thửa ra thành một layer riêng, mong các anh giúp, đây là file cad, em cảm ơn trước...

text mau.dwg

Lâu lâu nghịch chút đỡ buồn. Chủ thớt test thử nhé ^_^

(defun c:test  ()
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
              (cons 1 (substr value 1 pos))
              (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
              (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  ) ;defun

 

<<

Sửa lại 1 chút theo ý bạn, còn nguyên lý làm việc vẫn giữ nguyên ý bác Tuệ, chạy mượt hay không bạn tìm bác ấy nhé :)

>>

Sửa lại 1 chút theo ý bạn, còn nguyên lý làm việc vẫn giữ nguyên ý bác Tuệ, chạy mượt hay không bạn tìm bác ấy nhé :)

(defun c:hlay(/ ss Tue-dxf Tue-ent-Lpoint ename ename2 ss2 lh ent fl)
(setq fl "")
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun lh(dt tle goc)
(setvar "hpgaptol" 50.0)
(vl-cmdf "bhatch" "P" (getvar "hpname") tle goc "S" dt "" "")
)
(defun Tue-ent-Lpoint(e / i Lpoint);Tue-dxf
(if (wcmatch (Tue-dxf 0 e) "*POLYLINE")
(progn
 (if (= (type e) 'VLA-OBJECT) (setq e (vlax-vla-object->ename e)))
 (setq i -1)
 (Repeat (if (wcmatch (Tue-dxf 0 e) "*POLYLINE") (fix (1+ (vlax-curve-getEndParam e))) 2)
(setq Lpoint (append Lpoint (list (vlax-curve-getPointatParam e (setq i (1+ i))))))
 )
)
)
(if (wcmatch (Tue-dxf 0 e) "LINE")
 (setq Lpoint (append Lpoint (list (Tue-dxf 10 e) (Tue-dxf 11 e))))
)
Lpoint
)
(while (setq ent (entsel "\nDoi tuong chua layer mau :"))
 (setq  lay (Tue-dxf 8 (car ent))
fl (cond ((not (wcmatch lay fl))(strcat fl  lay ",")))
 )
)
(setq fl (vl-string-left-trim "," fl))
 (if (setq ss (ssget (list (cons 0 "*POLYLINE")
 (cons  8 (cond  ((setq tmp (vl-string-search "," fl)) (substr fl 1 (vl-string-search "," fl)))
  	(fl)
 )))))
(Progn    
 	(setq i -1)
 	(while (setq ename (ssname ss (setq i (1+ i))))
(setq ss2 (ssget "f" (Tue-ent-Lpoint ename) (list (cons 0 "*POLYLINE") (cons 8 fl))))
(lh  ss2  "1" "0")
 	)
))
)

Cám ơn bác nhiều nhé!

Nhưng hình như bác mới sửa được một ý thứ 2 trong 2 ý mà em muốn.

Còn lựa chọn mẫu hatch và scale nữa.

Mong bác giúp đỡ!

<<