Jump to content
InfoFile
Tác giả: hiepttr
Bài viết gốc: 310771
Tên lệnh: hhh show mhide mshow
Chương 10.2 : Text Window, Redraw

Làm đc 2 nhát chống cháy :D :D :D

Các bác chém nhẹ tay :v

Giờ thì phải rời ghế đã :D

;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HHH an mot nhom doi tuong, lenh duoc su dung 1 lan, 
;sau do co the hien lai nhom doi tuong cu bang lenh SHOW
(defun c:HHH( / i)
(prompt "\n Chon doi tuong can an !")
(setq ss_hide_25251325 (ssget))
(if ss_hide_25251325 
	(progn
		(setq i 0)
		(repeat (sslength...
>>

Làm đc 2 nhát chống cháy :D :D :D

Các bác chém nhẹ tay :v

Giờ thì phải rời ghế đã :D

;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HHH an mot nhom doi tuong, lenh duoc su dung 1 lan, 
;sau do co the hien lai nhom doi tuong cu bang lenh SHOW
(defun c:HHH( / i)
(prompt "\n Chon doi tuong can an !")
(setq ss_hide_25251325 (ssget))
(if ss_hide_25251325 
	(progn
		(setq i 0)
		(repeat (sslength ss_hide_25251325)
			(setq ename (ssname ss_hide_25251325 i)
				  i (1+ i))
			(redraw ename 2)
		) 	;repeat
	)	;progn
)	;if
)
(defun c:SHOW( / i)
(if ss_hide_25251325 
	(progn
		(setq i 0)
		(repeat (sslength ss_hide_25251325)
			(setq ename (ssname ss_hide_25251325 i)
				  i (1+ i))
			(redraw ename 1)
		) 	;repeat
	)	;progn
)	;if
)
;====================================
;;Bai 2: Lenh mHide an nhieu nhom doi tuong, lenh co the dung nhieu lan. 
;Sau do co the dung lenh mShow de hien lai tat ca cac nhom da an bang lenh mHide
(defun c:mHide( / ss lst_ss i)
(prompt "\n Chon doi tuong can an <mHide>!")
(setq ss (ssget))
(if ss 
	(progn 
		(setq lst_ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
			  ss_Mhide_25251325 (append lst_ss ss_Mhide_25251325)
			  i 0)
		(repeat (length lst_ss)
			(setq ename (nth i lst_ss)
				  i (1+ i))
			(redraw ename 2)
		) 	;repeat
	)	;progn
)	;if
)
(defun c:MSHOW( / i)
(if ss_Mhide_25251325 
	(progn
		(setq i 0)
		(repeat (length ss_Mhide_25251325)
			(setq ename (nth i ss_Mhide_25251325)
				  i (1+ i))
			(redraw ename 1)
		) 	;repeat
		(setq ss_Mhide_25251325 nil)
	)	;progn
)
)

<<

Filename: 310771_hhh_show_mhide_mshow.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 330690
Tên lệnh: xoa
Lisp xóa text (hoặc line) theo thứ tự cách quãng.

Chắc là bạn muốn xóa các Text hoặc Line theo các số thứ tự nhập vào tính từ bên trái, ví dụ "1,3,4,6". Nếu đúng vậy thì thử xem:

(defun C:XOA(/ lst1 lst2)
 (command "undo" "be")
 (prompt "\nChon cac Text hoac Line can xoa...")
 (setq lst1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
       lst1 (vl-sort lst1 '(lambda(x y) (< (cadr (assoc 10 (entget x))) (cadr...
>>

Chắc là bạn muốn xóa các Text hoặc Line theo các số thứ tự nhập vào tính từ bên trái, ví dụ "1,3,4,6". Nếu đúng vậy thì thử xem:

(defun C:XOA(/ lst1 lst2)
 (command "undo" "be")
 (prompt "\nChon cac Text hoac Line can xoa...")
 (setq lst1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
       lst1 (vl-sort lst1 '(lambda(x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y))))))
       lst2 (#String->ListString (getstring "\nNhap cac so thu tu can xoa : ") ","))
 (foreach n lst2
  (entdel (nth (1- (atoi n)) lst1))) 
 (command "undo" "e")
 (princ))
(defun #String->ListString(str del / pos lst)
 (while (setq pos (vl-string-search del str))
  (setq lst (cons (substr str 1 pos) lst)
        str (substr str (+ pos 1 (strlen del)))))
 (reverse (cons str lst)))
 

<<

Filename: 330690_xoa.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 330721
Tên lệnh: xoa
Lisp xóa text (hoặc line) theo thứ tự cách quãng.

Nãy post nhầm tí. Sửa lại:

(defun C:XOA(/ lst1 lst2)
 (command "undo" "be")
 (prompt "\nChon cac Text hoac Line can xoa...")
 (setq lst1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
       lst1 (vl-sort lst1 '(lambda(x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
 (foreach n '(2 4 5 7) ; List cac STT can xoa la (2 4 5 7), ban edit tai day nhe!
  (entdel (nth (1- n)...
>>

Nãy post nhầm tí. Sửa lại:

(defun C:XOA(/ lst1 lst2)
 (command "undo" "be")
 (prompt "\nChon cac Text hoac Line can xoa...")
 (setq lst1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
       lst1 (vl-sort lst1 '(lambda(x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
 (foreach n '(2 4 5 7) ; List cac STT can xoa la (2 4 5 7), ban edit tai day nhe!
  (entdel (nth (1- n) lst1))) 
 (command "undo" "e")
 (princ))
 

<<

Filename: 330721_xoa.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 330995
Tên lệnh: darr
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Chào các bác, hôm qua vào facbook của nhóm Cadmagic em "vớ" được lisp này của thầy ketxu và mang về "mông má" lại cho phù hợp với nhu cầu, giờ còn chút vấn đề nữa qua đây nhờ các bác chỉ giáo. Em nó đây:

(defun c:darr( / ST:Ss-Copy-Dynamic ST:SS->List-Vla ST:Ss-Delete ST:Check-Exist txt2num a b dir gr p0 px nx pxv ssFull ss1 vecx ans inc...
>>

Chào các bác, hôm qua vào facbook của nhóm Cadmagic em "vớ" được lisp này của thầy ketxu và mang về "mông má" lại cho phù hợp với nhu cầu, giờ còn chút vấn đề nữa qua đây nhờ các bác chỉ giáo. Em nó đây:

(defun c:darr( / ST:Ss-Copy-Dynamic ST:SS->List-Vla ST:Ss-Delete ST:Check-Exist txt2num a b dir gr p0 px nx pxv ssFull ss1 vecx ans inc *error*)
(vl-load-com)
;==============================================================================================================
(defun ST:Ss-Copy-Dynamic ( sslst n v dir / i number number1 matlist obj1 ss transmat xobj isText lst isReal)
  (setq ss (ssadd))
  (foreach xobj sslst
	(setq i 1)
(cond	(	(wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText")
			(setq	lst (txt2num (vla-get-textstring xobj)) 
					number1 (cadr lst)
					number (read number1)
				)
			(setq isText T)
			) ;Text Object
		(T 	setq isText nil)
	); end cond tong 

	(repeat n
  	(setq obj1 (vla-copy xobj)
  		  matList (list (list 1 0 0 (* i (car v) dir)) (list 0 1 0 (* i (cadr v) dir)) '(0 0 1 0) '(0 0 0 1))
  		  transmat (vlax-tmatrix matlist))
		  
  	(vla-transformby obj1 transMat)
	
   (if  (and isText (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText")) ; dieu kien tong
		(if (and (< number 9 ) (> (strlen number1) 1))
		
			(vla-put-textstring obj1 (strcat (car lst) "0" (rtos (setq number (1+ number)) 2 0) ))
			
			(vla-put-textstring obj1 (strcat (car lst) (rtos (setq number (1+ number)) 2 0) ))
			); end if
	 ); end if tong	 	 
	 
  	(ssadd (vlax-vla-object->ename obj1) ss)
  	(setq i (1+ i))
	)
  );end foreach
  ss 
)
;=============================================================
(defun ST:SS->List-Vla (ss / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (vlax-ename->vla-object e) l))
  )
)
;=====================================================================
(defun ST:Ss-Delete (ss / i)
  (mapcar 'vla-delete (ST:SS->List-Vla ss))
)
(defun ST:Check-Exist(lst1 lst2)(and (vl-remove nil (mapcar '(lambda(x)(vl-position x lst2)) lst1)))) ;from topic Dovui ^^
 (defun *error* (msg)    
    (if ss1 (ST:ss-delete ss1))    
  )
(defun txt2num ( string / so m chuoi kytu ) ; tach cac so o cuoi chuoi
 
 (setq so " 0123456789"
       m (strlen string)
	   chuoi "")
(while (and (>= m 1) (vl-string-search (setq kytu (substr string m 1)) so ) )
	   (setq m (1- m))
	   (if (/= kytu " " ) (setq chuoi (strcat kytu chuoi)))
)
(list (substr string 1  m ) chuoi)
)
;;==============================================================================

(grtext -1 "Dynamic LArray")
(command "undo" "be")
(setq a (ssget "_+.:E:S" '((-4 . "<OR")
									(0 . "TEXT,MTEXT,LINE")
									(-4 . "<AND") (0 . "LWPOLYLINE") (70 . 0)(-4 . "AND>")
									(-4 . "OR>"))
			)
		)
(cond (	(and a
			(or
				(= (cdr(assoc 0 (entget(ssname a 0)))) "LWPOLYLINE,LINE")
				(= (cdr(assoc 0 (entget(ssname a 0)))) "LINE")
				)
			(setq	b (ssget "_+.:E:S" '((0 . "TEXT,MTEXT")) ))
			)
		(setq a (SSADD (ssname b 0) a))
		)
	 (	(and a
			(or
				(= (cdr(assoc 0 (entget(ssname a 0)))) "TEXT")
				(= (cdr(assoc 0 (entget(ssname a 0)))) "MTEXT")
				)
			(setq	b (ssget "_+.:E:S" '((0 . "LWPOLYLINE,LINE")) ))
			)
		(setq a (SSADD (ssname b 0) a))
		)
	);end cond
(if (setq	ssFull (ST:SS->List-Vla a)
			p0 (getpoint "\n\U+0110i\U+1EC3m g\U+1ED1c :")
			px (getpoint p0 "\nH\U+01B0\U+1EDBng v\U+00E0 kho\U+1EA3ng c\U+00E1ch copy :")
			vecx (mapcar '- px p0)
		)
(progn
  (prompt "\nPick \U+0111i\U+1EC3m cu\U+1ED1i c\U+00F9ng :")
  (while (= (car (setq gr (grread nil 5 0))) 5)
	(if ss1 (ST:Ss-Delete ss1))
	(redraw)
	(setq pxv (mapcar '- (inters (cadr gr) (polar (cadr gr) (+ (/ pi 2.0) (angle px p0)) 1.0) p0 px nil) p0))
	(if (< (setq nx  (fix (/ (caddr (trans pxv 0 vecx)) (caddr (trans vecx 0 vecx))))) 0)
     	  (setq dir -1 nx (- nx)) (setq dir 1))
 
	(setq ss1 (ST:Ss-Copy-Dynamic ssFull nx vecx dir)) ; can chu y doan nay;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	(grdraw p0 (mapcar '+ p0 pxv) 3 1)
  )
)
)
(command "undo" "en")
(princ)

)

File cad để test đây:

https://www.dropbox.com/s/ukl1kdw7klbmo7f/Drawing2.dwg?dl=0.

 

 Khi để UCS ở chế độ W thì lisp chạy ngon lành . Nhưng khi đặt lại UCS thì các đường thằng array không theo ý muốn nữa. Trong file test sau khi đặt UCS, em bật chế độ Ortho on, chọn đối tượng, pick điểm gốc, pick điẻm chọn khoảng cách và hướng copy thì nó toàn copy theo góc như chưa thay đổi UCS. :D


<<

Filename: 330995_darr.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 330446
Tên lệnh: tinhtien vietso cta ctb ctc ctd
Chương 6 : Bài Tập

Em nộp tất cả các bài tập thầy còn lại ket ơi. Bài 6,7,8 làm dựa trên hàm con gợi ý của thầy :D.

(defun c:tinhtien(/ ); giatien soluong banhang m hangtonkho hangcu thongbao sosanh  ) ;Lam bai 5.5 bang vong lap
(setq giatien (list '("A" . 100) '("B" . 200) '("C" . 300) '("D" . 400) '("E" . 500)) 
      Soluong (list '("A" . 2) '("B" . 3) '("C" . 4) '("D" . 5) '("E" . 6)) 
	  banhang '( "A" "B" "A" "C" "C" "D" "B" "B"...
>>

Em nộp tất cả các bài tập thầy còn lại ket ơi. Bài 6,7,8 làm dựa trên hàm con gợi ý của thầy :D.

(defun c:tinhtien(/ ); giatien soluong banhang m hangtonkho hangcu thongbao sosanh  ) ;Lam bai 5.5 bang vong lap
(setq giatien (list '("A" . 100) '("B" . 200) '("C" . 300) '("D" . 400) '("E" . 500)) 
      Soluong (list '("A" . 2) '("B" . 3) '("C" . 4) '("D" . 5) '("E" . 6)) 
	  banhang '( "A" "B" "A" "C" "C" "D" "B" "B" "E" "E" "C") )
; Tinh toan tien ban hang trong ngay============================================
(setq tongsotien 0.0 
      m 0)	  
(repeat (length banhang)
(setq tongsotien (+ tongsotien (cdr(assoc (nth m banhang) giatien)))
      m (+ 1 m))
)
(princ (strcat "\nSo tien ban hang trong ngay la: " (rtos tongsotien 2 0)))

; Tinh toan so luong con lai cua cac mat hang trong kho===========================	  

(foreach x banhang (progn (setq hangcu (cdr (assoc x soluong))
	                            soluong (subst (cons x (- hangcu 1) )  (cons x hangcu ) soluong)
								) 
                     )
		 )
(foreach x soluong (princ (strcat "\nSo Luong mat hang " (car x) " con " (itoa (cdr x))))
	)
(princ)

; Thong bao mat hang da het====================================================
(foreach x soluong (if (eq (cdr x) 0) (princ (strcat"\nMat hang " (car x) " da het")) )                  
	)
(princ)	
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BT 6 - 7 - 8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun _pL(p w h n / l p1)
    (setq l (list p))
    (repeat n
            (setq     p1     (mapcar '+ p (list 0 h 0))
                    p     (mapcar '+ p (list w h 0))
                    l     (append l (list p1 p))
            )
    )
)
;Ham ve    cau thang tu list point lay o _pL    
(defun _mCT(l)(apply 'command (append (list "Pline") l (list ""))))

;Tao list point can viet chu tu list point ve bac lay o _pL
(defun _tL(l / rt)
    (setq i -1)
    (repeat (/ (length l) 2)
            (setq rt (append rt (list (nth (setq i (+ i 2)) l))))
    )
rt
)
;Ham danh so tu chieu cao chu, list point lay o _tL
(defun _mT(h l fi_num gia_so lam_tron / i )
    (setq i (- fi_num gia_so))
    (mapcar '(lambda(p)(command "text" p h 0 (rtos (setq i (+ gia_so i)) 2 lam_tron))) l)
)
; Ham thay tat cac bien he thong khi dung command
(defun start ()
    (setq  oldvar (mapcar 'getvar '(osmode cmdecho)))
    (mapcar 'setvar '("osmode" "cmdecho") '(0 0))
 )
(defun end ()
    (mapcar 'setvar '(osmode cmdecho) oldvar)
)
(defun *error* ( aaa)
    (end )
)
;6. Viet len man hinh mot chuoi so tang dan
(defun c:vietso ( / fi_num gia_so n kc goc p h w cao_chu)

    (setq    fi_num (getint "\nNhap So Bat dau:")
            gia_so (getint "\nNhap Gia So:")  
            n (getint "\nNhap So Luong:")
            kc (getreal "\nNhap Khoang Cach:")
            goc (getreal "\nNhap Goc Nghieng Theo Do:")
            p (getpoint "\nPick Diem Dau Tien:")
            goc (* goc pi (/ 1 180.0))
            h (* (sin goc) kc)
            w (* (cos goc) kc)
            cao_chu (* kc 0.3)
        )
    (start )        
    (setq listpoint(_tL (_pL p w h n)))
    (_mT  cao_chu listpoint fi_num gia_so 1 )
    (end )
)
;7 Viet Chuong Trinh Mat Cat Doc Cau Thang Mot Ve
;a Biet so Bac, Kich Thuoc Bac
(defun C:CTA ( / n h w p)
    (setq    n (getint "\nNhap So Bac:")
            h (getreal "\nNhap Chieu Cao Bac:")
            w (getreal "\nNhap Chieu Rong Bac:")
            p (getpoint "\nPick Diem Dat Cau Thang:")
            )
    (start )        
    (_mCT (_pL p w h n ))
    
    (end )
)
;b Biet Chieu Cao Nha, So Bac, Be Rong Mat Bac.
(defun C:CTB ( / cao_nha n w p h)
    (setq    cao_nha (getreal "\nNhap Chieu Cao Nha:")
            n (getint "\nNhap So Bac:")
            w (getreal "\nNhap Chieu Rong Bac:")
            p (getpoint "\nPick Diem Dat Cau Thang:")
            h (/ cao_nha n)
            )
    (start )        
    (_mCT (_pL p w h n ))    
    (end )
)
;C Biet Chieu Cao Nha, So Bac, Goc nghieng thang
(defun C:CTC ( /  cao_nha n p goc  w h)
    (setq    cao_nha (getreal "\nNhap Chieu Cao Nha:")
            n (getint "\nNhap So Bac:")
            goc (getreal "\nNhap Goc Nghieng Thang Theo Do:")
            p (getpoint "\nPick Diem Dat Cau Thang:")
            goc (* goc pi (/ 1.0 180.0) )
            h (/ cao_nha n)
            w (/ h (/ (sin goc) (cos goc) ) ) ; khong hieu vi sao viet ham tan khong ra ket qua nen danh chua chay nhu nay
            )
    (start )        
    (_mCT (_pL p w h n ))    
    (end )
)
;;;;;Bai 8 nang cap tu bai 7c
(defun C:CTD ( /  cao_nha n p goc  w h kword listpoint)
    (setq    cao_nha (getreal "\nNhap Chieu Cao Nha:")
            n (getint "\nNhap So Bac:")
            goc (getreal "\nNhap Goc Nghieng Thang Theo Do:")
            )
    (initget  "Y N")
    (setq kword (getkword "\nBan Co Muon Danh So Bac Khong :"))
    
    (setq    p (getpoint "\nPick Diem Dat Cau Thang:")
            goc (* goc pi (/ 1.0 180.0) )
            h (/ cao_nha n)
            w (/ h (/ (sin goc) (cos goc) ) ) ; khong hieu vi sao viet ham tan khong ra ket qua nen danh chua chay nhu nay)
            )
    (start )        
    (_mCT (_pL p w h n ))
    (if        (= kword "Y")
            (progn
                (setq listpoint(_tL (_pL p w h n)))
                (_mT  (* 0.25 h) listpoint 1 1 0 )
                )
    )
    (end )
)

<<

Filename: 330446_tinhtien_vietso_cta_ctb_ctc_ctd.lsp
Tác giả: hiepttr
Bài viết gốc: 331049
Tên lệnh: vd2
Chương 11.1 Cơ bản về hộp thoại trong Lisp - DCL

Theo "đường lối" của Nhóc, mình muốn được "thõa sức sáng tạo"

Nên mình làm cái này (code bên dưới)

Mong được góp ý & đồng ý cho qua cửa chương 11.1 để chạy đua với NHóc cho vui ! :D

p/s:

- Dạo này mình không có nhiều thời gian cho việc học nên ko theo kịp

- Thầy Két có thể thay đổi đường dẫn trong code lisp và "thử" >>>>> Mình xin dép :D :D:...

>>

Theo "đường lối" của Nhóc, mình muốn được "thõa sức sáng tạo"

Nên mình làm cái này (code bên dưới)

Mong được góp ý & đồng ý cho qua cửa chương 11.1 để chạy đua với NHóc cho vui ! :D

p/s:

- Dạo này mình không có nhiều thời gian cho việc học nên ko theo kịp

- Thầy Két có thể thay đổi đường dẫn trong code lisp và "thử" >>>>> Mình xin dép :D :D: D

 

 

Code:

//VD2: may tinh
VD2:dialog
	{
	label = "EX_1 Calculator";
	:column
		{
		:boxed_column
			{  height = 2;
			:text
				{ key = "scr"; value = "0"; alignment = right; }
			}
		:row
			{
			:column
				{
		
				:boxed_column
					{ key = "number";
					:row
						{
						:button
							{ label = "1"; height = 2; width = 2; key = "1"; }					
						:button
							{ label = "2"; height = 2; width = 2; key = "2"; }
						:button
							{ label = "3"; height = 2; width = 2; key = "3"; }
						}
					:row
						{
						:button
							{ label = "4"; height = 2; width = 2; key = "4"; }
						:button
							{ label = "5"; height = 2; width = 2; key = "5"; }
						:button
							{ label = "6"; height = 2; width = 2; key = "6"; }
						}
					:row
						{
						:button
							{ label = "7"; height = 2; width = 2; key = "7"; }
						:button
							{ label = "8"; height = 2; width = 2; key = "8"; }
						:button
							{ label = "9"; height = 2; width = 2; key = "9"; }
						}
					:button
						{ label = "0"; height = 2; width = 2; key = "0"; }
					}
				:row
					{
					:button
						{ label = "Exit"; height = 2; width = 2; key = "cancel"; is_default = false; is_cancel = true; }
					:spacer {width = 10;}
					:toggle
						{ key = "tog1"; label = "Input Real"; value = "1"; }
					:button
						{ label = "."; height = 2; width = 2; key = "dot"; }
					}
				}
			:column
				{
				:boxed_column
					{
					:button
						{ label = "+"; height = 2; width = 2; key = "add"; }
					:button
						{ label = "-"; height = 2; width = 2; key = "sub"; }
					:button
						{ label = "x"; height = 2; width = 2; key = "mul"; }
					:button
						{ label = "/"; height = 2; width = 2; key = "div"; }
					}
				:button
					{ label = "="; height = 5; width = 2; key = "tinh"; is_default = true; }
				}
			}
		}
	}

 

 

Code lisp:

(defun c:VD2()
(vl-load-com)
(or cal (arxload "geomcal"))
(defun tinh ()
	(if (/= id t)
		(progn
			(princ 
				(setq 
					kq (vl-princ-to-string 
							(cond 
								((cal (strcat "1.0*" (get_tile "scr"))))
								(t nil)
							)
						)))
			(set_tile "scr" kq)
			(setq id t)
		)
	)
	(princ)
)
(defun input_num (num / phep_toan)
	(setq phep_toan (get_tile "scr"))
	(if (or (= "0" phep_toan) id) (setq phep_toan ""))
	(setq phep_toan (strcat phep_toan (itoa num)))
	(set_tile "scr" phep_toan)
	(setq id nil)
)
(defun input_operations (ope_code / phep_toan)
	(setq phep_toan (get_tile "scr"))
	(setq phep_toan (strcat phep_toan (chr ope_code)))
	(set_tile "scr" phep_toan)
	(setq id nil)
)
(defun set_input ( / code)
	(setq code (get_tile "tog1"))
	(if (= "1" code) (mode_tile "dot" 0) 	;enable
		(mode_tile "dot" 1)	;disable
		)
)
(setq dcl_id (load_dialog "C:/Documents and Settings/tbc/Desktop/nhap/VDS.dcl"))
(if (not (new_dialog "VD2" dcl_id)) 
	(progn
		(alert "*** Khong tom thay file DCL ! ***")
		(exit)
		)
)
(action_tile "1" "(input_num 1)")
(action_tile "2" "(input_num 2)")
(action_tile "3" "(input_num 3)")
(action_tile "4" "(input_num 4)")
(action_tile "5" "(input_num 5)")
(action_tile "6" "(input_num 6)")
(action_tile "7" "(input_num 7)")
(action_tile "8" "(input_num 8)")
(action_tile "9" "(input_num 9)")
(action_tile "0" "(input_num 0)")
(action_tile "tog1" "(set_input)")
(action_tile "add" "(input_operations 43)")
(action_tile "sub" "(input_operations 45)")
(action_tile "mul" "(input_operations 42)")
(action_tile "div" "(input_operations 47)")
(action_tile "dot" "(input_operations 46)")
(action_tile "cancel" "(setq ddiag 1)(done_dialog)")
(action_tile "tinh" "(tinh)")
(start_dialog)
(unload_dialog dcl_id) 
(if (= ddiag 1) (princ "\n*** Xong ! ***"))
(princ)
)

<<

Filename: 331049_vd2.lsp
Tác giả: nhantony
Bài viết gốc: 322873
Tên lệnh: tl3
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn
(defun C:TL3( / ss L te p1 p2)

(while (and (setq p1 (getpoint "\n Chon diem thu nhat :"))
	(setq p2 (getpoint p1 "\n Chon diem thu hai :"))
)
(setq L (distance p1 p2))
 
 
(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
)

Nhờ các bác sửa lệnh này tính theo khoảng cách dùm mình được không :)

Similar topics from...
>>
(defun C:TL3( / ss L te p1 p2)

(while (and (setq p1 (getpoint "\n Chon diem thu nhat :"))
	(setq p2 (getpoint p1 "\n Chon diem thu hai :"))
)
(setq L (distance p1 p2))
 
 
(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
)

Nhờ các bác sửa lệnh này tính theo khoảng cách dùm mình được không :)


<<

Filename: 322873_tl3.lsp
Tác giả: phanthanh536
Bài viết gốc: 331521
Tên lệnh: qq
Làm sao để xoay trục 180 độ mà text không bị ngược?
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/101999-nho-cac-bac-viet-giup-e-lips-pick-1-diem-xuat-ra-toa-do-duoi-dang-x-y/
 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to...
>>
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/101999-nho-cac-bac-viet-giup-e-lips-pick-1-diem-xuat-ra-toa-do-duoi-dang-x-y/
 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to the database
;;; based upon the value of coordinates passed from module "MAIN" .
;;; Null points are ignored.
 
(defun do_put_leader( xyp )
(command "_.leader" rwc pause "" xyp "")
)
 
;;;----------------------------- xyz coordinate breakdown ----------------------
;;; This routine accepts a point from the calling function and breaks it down
;;; into X,Y values.
 
(defun get_xyz ( pt )
  (strcat "(" (rtos (* 0.001 (car pt)) 2 3) ";" (rtos (* 0.001 (cadr pt)) 2 3) ")"))
 
 
;;;-------------------Secondary main module------------------------------------
;;; Accepts the user input and allows the user to select many objects in
;;; succession.
 
(defun main()
(setq olddim (getvar "dimstyle"))
(setq a (getreal "\n Input Text Height for Annotation : <2.5> "))
(if (null a) (setq a 2.5))
(setvar "dimtxt" a)
  
(while (setq rwc (getpoint "\nSelect point: "))
  (do_put_leader (get_xyz rwc)) 
)
(command "dimstyle" "restore" olddim)
)
 

lisp đó đây các bác


<<

Filename: 331521_qq.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 331576
Tên lệnh: coor coor coort coor-geo ptxl
Làm sao để xoay trục 180 độ mà text không bị ngược?

bác cũng làm trắc đạc ạ. vấn đề ko phải để e trút dữ liệu. e đang làm tọa độ cho các tim cọc (gần 1000 tim) trên cad để đem ra công trường nhập vào máy toàn đạc. trước kia e có hơn trăm cái tim cột thôi nên e sửa thủ công đc, giờ nhiều quá bác ak. e chỉ biết sơ sơ về trắc đạc thôi chứ công việc...

>>

bác cũng làm trắc đạc ạ. vấn đề ko phải để e trút dữ liệu. e đang làm tọa độ cho các tim cọc (gần 1000 tim) trên cad để đem ra công trường nhập vào máy toàn đạc. trước kia e có hơn trăm cái tim cột thôi nên e sửa thủ công đc, giờ nhiều quá bác ak. e chỉ biết sơ sơ về trắc đạc thôi chứ công việc chính của e là kĩ thuật, rất mong đc bác chỉ giáo thêm

máy toàn đạc nào cũng có chế độ trút số liệu từ máy toàn đạc vào máy tính và ngược lại. Cái này nói ra rất dài dòng với lại trút số liệu của thằng topcon 230 nói chung khá là củ chuối bạn tự tìm hiểu thêm. Còn  lấy tọa độ từ file cad ra file text để trút vào máy toàn đạc thì bạn có thể dùng lisp này (lệnh coor). Luôn luôn ghi nhớ một điều là hệ tọa độ của cad với hệ tọa độ trắc địa ngược nhau, đổi y thành x và x thành y:

(defun c:COOR (/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus Npt)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
  (setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
  (if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим  <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
        (strcat "\nSpecify mode  <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
  (if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
   (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
     (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
     (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")
(setq Npt (getint (if IsRus "\nНачальный номер точки <Не маркировать> : " "\nStart number of points <Don't mark> : " )))
(initget "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nСохранить координаты в  <Файл> : "
"\nSave coordinates to  <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))(setq oFlag Npt)(if (numberp Npt)
(foreach ln ptlst
  (text-draw                 
    (itoa Npt)               
    (polar ln (/ pi 4) 1.)   
    (getvar "TEXTSIZE")      
    0                        
    nil
    )
  (setq Npt (1+ Npt))))
(setq Npt oFlag)    
(setq ptLst (mapcar '(lambda(x)(mapcar 'rtos x)) ptlst))
(cond ((and (= "Text" sFlag)(setq filPath
       (getfiled (if IsRus "Сохранение координат в текстовый файл" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
       (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (if (numberp Npt)(strcat (itoa Npt) ",") "")(car ln)","(cadr ln)
         (if(= 3(length ln))(strcat ","(nth 2 ln)))) cFile)(if (numberp Npt)(setq Npt (1+ Npt))))(close cFile)(initget "Yes No")
       (setq oFlag(getkword (if IsRus "\nОткрыть файл?  <No> : " "\nOpen text file?  <No> : " )))
       (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
     ((= "Excel" sFlag)(if (numberp Npt)(progn
      (setq ptlst (mapcar '(lambda(x)(cons (1- (setq Npt (1+ Npt))) x)) ptlst))
      (xls ptlst '("N" "X" "Y" "Z") nil "COORN"))
      (xls ptLst nil nil "COOR"))); end condition #2
     (t nil)))) (princ)); end of c:COOR
;|================== XLS ========================================
*  published http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf
               http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW
* Purpose: Export of the list of data Data-list in Excell
*             It is exported to a new leaf of the current book.
              If the book is not present, it is created
* Arguments:
              Data-list — The list of lists of data (LIST)
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Each list of a kind (Value1 Value2... VlalueN) enters the name in
                            a separate line in corresponding columns (Value1-A Value2-B and .т.д.)
                  header —  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                            If header nil, is accepted ("X" "Y" "Z")
                 Colhide —  The list of alphabetic names of columns to hide or nil — to not hide ("A" "C" "D") — to hide columns A, C, D
                 Name_list — The name of a new leaf of the active book or nil — is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;


;|================== XLS ========================================
* Опубликовано http://www.autocad.ru/cgi-bin/f1/board.cgi?t=19833nl&page=2
               http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf
               http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              Data-list — список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header —  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide —  список буквенных названий стоблцов для скрытия или nil — не скрывать
                            ("A" "C" "D") — скрыть столбцы A, C, D
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))|;
(vl-load-com)
(defun xls ( Data-list header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
              *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысячей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length Data-list)(setq iz_listo (car Data-list))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq Data-list (cdr Data-list))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
;;;Отрисовка текста
;;; txt - текст
;;; pnt - точка отрисовки в ПСК
;;; heigtht - высота
;;; rotation - угол поворота
;;;justification - или nil
;;;Возвращает имя примитива
(defun text-draw (txt pnt height rotation justification)
   (if (null pnt)(command "_.-TEXT" "" txt)
   (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
    0.0
       ) ;_ end of =
     (progn
     ;; нулевая высота текста
       (if justification
   (command "_.-TEXT" "_J" justification "_none" pnt height rotation txt)
   (command "_.-TEXT" "_none" pnt height rotation txt)
       ) ;_ end of if
     ) ;_ end of progn
     (progn
       ;; фиксированнная высота
       (if justification
   (command "_.-TEXT" "_J" justification "_none" pnt rotation txt)
   (command "_.-TEXT" "_none" pnt rotation txt)
       ) ;_ end of if
     ) ;_ end of progn
   ) ;_ end of if
     )
  (entlast)
)
(defun c:COOR(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
	(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
	(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим  <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
	      (strcat "\nSpecify mode  <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
	(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
	 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
	   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
	   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")(initget "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nСохранить координаты в  <Файл> : "
"\nSave coordinates to  <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))
(cond ((and (= "Text" sFlag)(setq filPath
       (getfiled (if IsRus "Сохранение координат в текстовый файл" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
       (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (rtos(car ln))","(rtos(cadr ln))
         (if(= 3(length ln))(strcat ","(rtos(nth 2 ln))))) cFile))(close cFile)(initget "Yes No")
       (setq oFlag(getkword (if IsRus "\nОткрыть файл?  <No> : " "\nOpen text file?  <No> : " )))
       (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
     ((= "Excel" sFlag)(xls (mapcar '(lambda(x)(mapcar 'rtos x)) ptLst) nil nil "COOR")); end condition #2
     (t nil)))) (princ)); end of c:COOR

(defun c:COORT(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus txtList buf pat)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
	(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
	(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим  <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
	      (strcat "\nSpecify mode  <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
	(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
	 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
	   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
	   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst
  (progn
    (setq objSet(ssget "_X" (list '(0 . "*TEXT")(cons 410 (getvar "CTAB")))))
    (setq lw (vl-remove-if 'listp(mapcar 'cadr(ssnamex objSet))))
    (setq lw (mapcar '(lambda(x)(setq x (entget x))(list (cdr(assoc 10 x))(cdr(assoc 1 x)))) lw))
    (foreach pt ptlst
      (setq buf (mapcar '(lambda(x)(list (distance pt (car x))(cadr x))) lw))
      (setq pat (car buf))
      (foreach dst buf (if (< (car dst) (car pat))(setq pat dst)))
      (setq txtList (cons (cadr pat) txtList))
      )
    (setq txtList (reverse txtList))
    (princ "\n+++++++ Coordinates list +++++++\n")
    (setq ptLst (mapcar '(lambda (x) (trans x 0 1)) ptLst))
    (setq buf
    (mapcar '(lambda (x y)
               (princ (strcat "\n" y "  "
                              (rtos (car x))
                              ","
                              (rtos (cadr x))
                              (if (= 3 (length x))
                                (strcat "," (rtos (nth 2 x)))
                                ""
                              ) ;_ end of if
                      ) ;_ end of strcat
               ) ;_ end of princ
              (list y (rtos (car x))(rtos (cadr x))
                              (if (= 3 (length x))(rtos (nth 2 x))) ;_ end of if
                      )
             ) ;_ end of lambda
            ptLst txtList
    );_ end mapcar
          )
    (princ "\n\n+++++++++ End of list +++++++++")
    (initget
      "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not"
    ) ;_ end of initget
    (setq sFlag
           (getkword
             (if IsRus
               "\nСохранить координаты в  <Файл> : "
               "\nSave coordinates to  <Text> : "
             ) ;_ end of if
           ) ;_ end of getkword
    ) ;_ end of setq
    (if (null sFlag)
      (setq sFlag "Text")
    ) ;_ end of if
    (cond ((and (= "Text" sFlag)
                (setq filPath
                       (getfiled (if IsRus
                                   "Сохранение координат в текстовый файл"
                                   "Save Coordinates to Text File"
                                 ) ;_ end of if
                                 "Coordinates.txt"
                                 "txt;csv"
                                 33
                       ) ;_ end of getfiled
                ) ;_ end of setq
           ) ;_ end of and
           (setq cFile (open filPath "w"))
           (foreach ln buf
             (write-line
               (apply 'strcat
               (append (list(car ln))
                       (mapcar '(lambda(x)(strcat "," x))
                               (cdr ln)
                               )
                       )
                 )     
               cFile
             ) ;_ end of write-line
           ) ;_ end of foreach
           (close cFile)
           (initget "Yes No")
           (setq oFlag (getkword (if IsRus
                                   "\nОткрыть файл?  <No> : "
                                   "\nOpen text file?  <No> : "
                                 ) ;_ end of if
                       ) ;_ end of getkword
           ) ;_ end of setq
           (if (= oFlag "Yes")
             (startapp "notepad.exe" filPath)
           ) ;_ end of if
          )                                       ; end condition #1
          ((= "Excel" sFlag)
           (xls buf
                '("Номер точки" "X" "Y" "Z")
                nil
                "COORM"
           ) ;_ end of xls
          )                                       ; end condition #2
          (t nil)
    ) ;_ end of cond
  ) ;_ end of progn
) ;_ end of if
 (princ))
(defun c:COOR-GEO (/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus txtList buf pat geo txt)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
	(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
	(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим  <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
	      (strcat "\nSpecify mode  <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
	(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
	 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
	   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
	   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst
  (progn
    (if (setq objSet(ssget "_X" (list '(0 . "*TEXT")(cons 410 (getvar "CTAB")))))
      (progn
	 (setq lw (vl-remove-if 'listp(mapcar 'cadr(ssnamex objSet))))
    (setq lw (mapcar '(lambda(x)(setq x (entget x))(list (cdr(assoc 10 x))(cdr(assoc 1 x)))) lw))
    (foreach pt ptlst
      (setq buf (mapcar '(lambda(x)(list (distance pt (car x))(cadr x))) lw))
      (setq pat (car buf))
      (foreach dst buf (if (< (car dst) (car pat))(setq pat dst)))
      (setq txtList (cons (cadr pat) txtList))
      )
    (setq txtList (reverse txtList))
	)
      (setq txtList '("? 1"))
      )
    ;;; Формируем геодезические координаты (переворачиваем X и Y, вычисляем расстояние и номера точек)
    (setq lw 0)
    (repeat (length ptLst)
      (setq curPt (nth lw ptLst)) ;_Текущая точка
      (if (setq buf (nth (1+ lw) ptLst)) ;_Последующая
	(progn
	(setq txt (nth (1+ lw) txtList)) ;_Номер следующей точки
	(if (null txt)(setq txt (strcat "? "(itoa (+ 2 lw)))))
	)
	(progn
	(setq buf (car ptLst) txt (car txtList))
	(if (null txt)(setq txt "? 1"))
	)
	)
      (setq curPt (list (cadr curPt)(car curPt))) ;_ Координаты текущей точки (переворачиваем)
      (setq buf (list (cadr buf)(car buf))) ;_ Координаты следующей (переворачиваем)
      (setq geo (cons (list
			(if (nth lw txtList)(nth lw txtList)(strcat "? "(itoa (1+ lw)))) ;_ Номер точки
			curPt                                                       ;_ Координаты
			                                                            ;_ Дир. угол
			(vl-string-subst "' " "'"  ;_заменяем символ '(мин) на символ '' '(c пробелом)
			  (vl-string-subst "° " "d" ;_ заменяем символ d(град) на символ '° '
			    (angtos (angle curPt buf) 1 3)
			    )
			  )
			(distance curPt buf) ;_Расстояние
			txt ;_ На точку
			)
		      geo
		      )
	    )
			
      (setq lw (1+ lw))
      )
    (setq geo (reverse geo))
    (princ "\n+++++++ Coordinates list +++++++\n")
    (setq buf
    (mapcar '(lambda (x)
               (princ (strcat "\n" (nth 0 x) "  "
                              (rtos (car (nth 1 x)))
                              ","
                              (rtos (cadr (nth 1 x)))
                      ) ;_ end of strcat
               ) ;_ end of princ
	       (list
		 (nth 0 x)                  ;_ Номер точки
		 (rtos (car (nth 1 x)) 2 2) ;_ Коорд X
		 (rtos (cadr (nth 1 x)) 2 2);_ Коорд Y
		 (nth 2 x)                  ;_ Дир угол
		 (rtos (nth 3 x) 2 2)       ;_ Расстояние
		 (nth 4 x)                  ;_ На точку
		 )
              ) ;_ end of lambda
            geo
    );_ end mapcar
	  )
    (princ "\n\n+++++++++ End of list +++++++++")
    (initget
      "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not"
    ) ;_ end of initget
    (setq sFlag
           (getkword
             (if IsRus
               "\nСохранить координаты в  <Файл> : "
               "\nSave coordinates to  <Text> : "
             ) ;_ end of if
           ) ;_ end of getkword
    ) ;_ end of setq
    (if (null sFlag)
      (setq sFlag "Text")
    ) ;_ end of if
    (cond ((and (= "Text" sFlag)
                (setq filPath
                       (getfiled (if IsRus
                                   "Сохранение координат в текстовый файл"
                                   "Save Coordinates to Text File"
                                 ) ;_ end of if
                                 "Coordinates.txt"
                                 "txt;csv"
                                 33
                       ) ;_ end of getfiled
                ) ;_ end of setq
           ) ;_ end of and
           (setq cFile (open filPath "w"))
           (foreach ln buf
             (write-line
               (apply 'strcat
               (append (list(car ln))
                       (mapcar '(lambda(x)(strcat "," x))
                               (cdr ln)
                               )
                       )
                 )     
               cFile
             ) ;_ end of write-line
           ) ;_ end of foreach
           (close cFile)
           (initget "Yes No")
           (setq oFlag (getkword (if IsRus
                                   "\nОткрыть файл?  <No> : "
                                   "\nOpen text file?  <No> : "
                                 ) ;_ end of if
                       ) ;_ end of getkword
           ) ;_ end of setq
           (if (= oFlag "Yes")
             (startapp "notepad.exe" filPath)
           ) ;_ end of if
          )                                       ; end condition #1
          ((= "Excel" sFlag)
           (xls buf
                '("Номер точки" "X" "Y" "Дир. угол" "Расстояние" "На точку")
                nil
                "COORM"
           ) ;_ end of xls
          )                                       ; end condition #2
          (t nil)
    ) ;_ end of cond
  ) ;_ end of progn
) ;_ end of if
 (princ))

 (defun C:PTXL ( / ss lst pt dL lstp lstt ret Z)
 ;;;http://forum.dwg.ru/showthread.php?t=14353
;;;Команда PTXL.
;;;Max distance from point to text - максимальное отклонение точки и текста.
;;;Координаты текста берутся из поля 10 (выравнивание влево)
;;;Если найдено несколько текстов с отклонением меньше Max distance, берется текст с наименьшим расстоянием.

  (vl-load-com)
  (initget 1)
  (setq dL (getreal "\nMax distance from point to text: "))
  (and
  (princ "\nSelect text and Point")
  (setq ss (ssget "_:L" '((0 . "TEXT,Point"))))
  (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (foreach en lst
    (if (= (cdr(assoc 0 (entget en))) "POINT")
      (setq lstp (cons en lstp))
      (setq lstt (cons en lstt))
      )
    )
  (foreach en lstp
    (setq pt (cdr(assoc 10 (entget en))))
    (setq pt (mapcar '+ pt '(0 0)))
    (setq lst (vl-remove-if '(lambda(txt)
          (< (distance pt
         (mapcar '+ (cdr(assoc 10 (entget txt)))
             '(0 0)))
      dL
      )
          )
  lstt
  )
   )
    (setq lst (vl-sort lst '(lambda(x y)
         (< (distance pt (mapcar '+ (cdr(assoc 10 (entget x)))  '(0 0)))
     (distance pt (mapcar '+ (cdr(assoc 10 (entget y)))  '(0 0))) 
      )
         )
         )
   )
    (setq Z (cdr(assoc 1 (entget (car lst)))))
    (setq Z (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t" Z)))
    (setq Z (atof Z))
    (setq pt (append pt (list Z)))
    (setq ret (cons pt ret))
    )
  )
    (if ret (xls ret '("X" "Y" "Z") nil nil))
    (princ)
)
(princ "\nType COOR, COORN, COORT or COOR-GEO in command line")

<<

Filename: 331576_coor_coor_coort_coor-geo_ptxl.lsp
Tác giả: Tot77
Bài viết gốc: 331592
Tên lệnh: qq
Làm sao để xoay trục 180 độ mà text không bị ngược?

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

 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to the database
;;; based upon the value of coordinates passed from module "MAIN" .
;;; Null points are ignored.
 
(defun do_put_leader(...
>>

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

 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to the database
;;; based upon the value of coordinates passed from module "MAIN" .
;;; Null points are ignored.
 
(defun do_put_leader( xyp / en eg)
(setq en (entlast)) 
(command "_.leader" rwc pause "" xyp "") 
(while (setq en (entnext en))
(if (= "MTEXT" (cdr (assoc 0 (entget en))))
(setq eg (entget en)
eg (entmod (subst (cons 210 '(0 0 1)) (assoc 210 eg) eg))) 
 )
)
)
 
;;;----------------------------- xyz coordinate breakdown ----------------------
;;; This routine accepts a point from the calling function and breaks it down
;;; into X,Y values.
 
(defun get_xyz ( pt )
 (strcat "(" (rtos (* 0.001 (car pt)) 2 3) ";" (rtos (* 0.001 (cadr pt)) 2 3) ")"))
 
 
;;;-------------------Secondary main module------------------------------------
;;; Accepts the user input and allows the user to select many objects in
;;; succession.
 
(defun main()
(setq olddim (getvar "dimstyle") 
a (getreal "\n Input Text Height for Annotation : <2.5> "))
(if (null a) (setq a 2.5))
(setvar "dimtxt" a)
 
(while (setq rwc (getpoint "\nSelect point: "))
(do_put_leader (get_xyz rwc))
)
(command "dimstyle" "restore" olddim)
)
 

<<

Filename: 331592_qq.lsp
Tác giả: Tot77
Bài viết gốc: 331652
Tên lệnh: qq
Làm sao để xoay trục 180 độ mà text không bị ngược?

 Thử cái này nữa.

 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to the database
;;; based upon the value of coordinates passed from module "MAIN" .
;;; Null points are ignored.
 
(defun do_put_leader(...
>>

 Thử cái này nữa.

 
(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- Leader Placement Routine ---------------------
;;; Here is where the leaders are actually written to the database
;;; based upon the value of coordinates passed from module "MAIN" .
;;; Null points are ignored.
 
(defun do_put_leader( xyp / en eg)
(setq en (entlast)) 
(command "_.leader" rwc pause "" xyp "") 
(while (setq en (entnext en))
(if (= "MTEXT" (cdr (assoc 0 (entget en))))
(progn 
 (setq eg (entget en)
eg (subst (cons 210 '(0 0 1)) (assoc 210 eg) eg)
eg (subst (cons 71 7) (assoc 71 eg) eg)
)
(entmod eg)
)
 )
)
)
 
;;;----------------------------- xyz coordinate breakdown ----------------------
;;; This routine accepts a point from the calling function and breaks it down
;;; into X,Y values.
 
(defun get_xyz ( pt )
 (strcat "(" (rtos (* 0.001 (car pt)) 2 3) ";" (rtos (* 0.001 (cadr pt)) 2 3) ")"))
 
 
;;;-------------------Secondary main module------------------------------------
;;; Accepts the user input and allows the user to select many objects in
;;; succession.
 
(defun main()
(setq olddim (getvar "dimstyle") 
a (getreal "\n Input Text Height for Annotation : <2.5> "))
(if (null a) (setq a 2.5))
(setvar "dimtxt" a)
 
(while (setq rwc (getpoint "\nSelect point: "))
(do_put_leader (get_xyz rwc))
)
(command "dimstyle" "restore" olddim)
)
 

<<

Filename: 331652_qq.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 331791
Tên lệnh: ha
Xin lisp đánh số thứ tự các dòng text (giống bullet and numbering trong word)

Lisp đánh số thứ tự cho các dòng Text.

; CadViet.com - 23/01/2015 - by Doan Van Ha
; Chuc nang: Danh STT cho cac dong Text, tu tren xuong duoi.
(defun C:HA(/ ss lst n str elist)
 (command "undo" "be")
 (if (setq ss (ssget '((0 . "TEXT"))))
  (progn
   (setq lst
    (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    '(lambda (x y)
      (> (caddr  (assoc 10 (entget x))) (caddr (assoc 10 (entget...
>>

Lisp đánh số thứ tự cho các dòng Text.

; CadViet.com - 23/01/2015 - by Doan Van Ha
; Chuc nang: Danh STT cho cac dong Text, tu tren xuong duoi.
(defun C:HA(/ ss lst n str elist)
 (command "undo" "be")
 (if (setq ss (ssget '((0 . "TEXT"))))
  (progn
   (setq lst
    (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    '(lambda (x y)
      (> (caddr  (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
   (setq n 1 str "-")   ; Edit tai day!
   (foreach ent lst
    (setq elist (entget ent) ass (assoc 1 elist))
    (entmod (subst (cons 1 (strcat (itoa n) str (cdr ass))) ass elist))
(setq n (1+ n)))))
 (command "undo" "e")
 (princ))
 

<<

Filename: 331791_ha.lsp
Tác giả: khongbietthihoi
Bài viết gốc: 331782
Tên lệnh: tcd
Sửa lisp đổi màu giá trị Text?

Em không rành về autolisp… Em có đoạn code tính tổng chiều dài các đoạn thẳng sau đó gán vào giá trị Text. Mong các anh sửa giúp "Giá trị text đổi thành màu ĐỎ sau khi gán giá trị". Chân thành cảm ơn.

(defun C:TCD (/ tot_len ss e_name e_record e_type)
  (setq tot_len 0.0)
  (setq ss (ssget))
  (if (null ss)
    (exit)
  )
  (while (> (sslength ss) 0)
    (setq e_name (ssname ss...
>>

Em không rành về autolisp… Em có đoạn code tính tổng chiều dài các đoạn thẳng sau đó gán vào giá trị Text. Mong các anh sửa giúp "Giá trị text đổi thành màu ĐỎ sau khi gán giá trị". Chân thành cảm ơn.

(defun C:TCD (/ tot_len ss e_name e_record e_type)
  (setq tot_len 0.0)
  (setq ss (ssget))
  (if (null ss)
    (exit)
  )
  (while (> (sslength ss) 0)
    (setq e_name (ssname ss 0))
    (setq e_record (entget e_name))
    (setq e_type (cdr (assoc '0 e_record)))
    (cond ((wcmatch e_type
		    "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"
	   )
	   (command "lengthen" e_name "")
	   (setq tot_len (+ tot_len (getvar "PERIMETER")))
	   (ssdel e_name ss)
	  )
	  ((wcmatch e_type "MLINE") (add_mline))
	  (e_type (ssdel e_name ss))
    )
  )
  (setq	te (entget (car (entsel "\n Chon Text de gan ket qua :")))
	te (subst (cons 1 (rtos tot_len 2 2)) (assoc 1 te) te)
  )
  (entmod te)
  (princ)
)

 


<<

Filename: 331782_tcd.lsp
Tác giả: ketxu
Bài viết gốc: 332045
Tên lệnh: odo
nhờ các bác viết hộ em lisp offset đặc biệt này ạ

Quick code cho bạn :

;Double Double Offset 26-1-2015 
(defun c:odo (/ ss)
	(grtext -1 "Free double double offset from CADviet @ketxu")
	(or #d1 (setq #d1 10))
	(or #d2 (setq #d2 20))
	(setq #d1 (cond ((getreal (strcat "D1 <" (rtos #d1) "> : ")))(#d1)))
	(setq #d2 (cond ((getreal (strcat "D2 <" (rtos #d2) "> : ")))(#d2)))
	(princ "\nSelect Objects : ")	
	(if (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
		(mapcar...
>>

Quick code cho bạn :

;Double Double Offset 26-1-2015 
(defun c:odo (/ ss)
	(grtext -1 "Free double double offset from CADviet @ketxu")
	(or #d1 (setq #d1 10))
	(or #d2 (setq #d2 20))
	(setq #d1 (cond ((getreal (strcat "D1 <" (rtos #d1) "> : ")))(#d1)))
	(setq #d2 (cond ((getreal (strcat "D2 <" (rtos #d2) "> : ")))(#d2)))
	(princ "\nSelect Objects : ")	
	(if (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
		(mapcar '(lambda(o)(mapcar '(lambda(s f)(vla-offset o (* s f))) (list #d1 #d1 #d2 #d2) '(1 -1 1 -1)))
			(mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		)		
	)
(princ)
)
(vl-load-com)

<<

Filename: 332045_odo.lsp
Tác giả: hiepttr
Bài viết gốc: 311125
Tên lệnh: hhh show mhide mshow game nhay hl
Chương 10.2 : Text Window, Redraw

@Thầy Ket: Mình chạy trên cad2004 thì ok, nhung trên cad 2008,2009 thì không nháy >>> chắc là do ảnh hưởng của 1 biến hệ thống nào đó :D

 

Mình đã hoàn thành BT lần này, mình sửa lại tí cho gọn gàng >>> xin đc post lại:

 

;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HIDE an mot nhom doi tuong, lenh duoc su dung 1 lan, 
;sau do co the hien lai nhom doi...
>>

@Thầy Ket: Mình chạy trên cad2004 thì ok, nhung trên cad 2008,2009 thì không nháy >>> chắc là do ảnh hưởng của 1 biến hệ thống nào đó :D

 

Mình đã hoàn thành BT lần này, mình sửa lại tí cho gọn gàng >>> xin đc post lại:

 

;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HIDE an mot nhom doi tuong, lenh duoc su dung 1 lan, 
;sau do co the hien lai nhom doi tuong cu bang lenh SHOW
(defun c:HHH()
(prompt "\n Chon doi tuong can an !")
(setq ss_hide_25251325 (ssget))
(if ss_hide_25251325 (MREDRAW ss_hide_25251325 2))
)
(defun c:SHOW( / i)
(if ss_hide_25251325 (MREDRAW ss_hide_25251325 1))
)
;====================================
;;Bai 2: Lenh mHide an nhieu nhom doi tuong, lenh co the dung nhieu lan. 
;Sau do co the dung lenh mShow de hien lai tat ca cac nhom da an bang lenh mHide
(defun c:mHide( / ss lst_ss i)
(prompt "\n Chon doi tuong can an <mHide>!")
(setq ss (ssget))
(if ss 
	(progn 
		(setq lst_ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
			  ss_Mhide_25251325 (append lst_ss ss_Mhide_25251325)
		)
		(MREDRAW ss 2)
	)	;progn
)	;if
)
(defun c:MSHOW( / i ss)
(if ss_Mhide_25251325 
	(progn
		(setq ss (acet-list-to-ss ss_Mhide_25251325))
		(MREDRAW ss 1)
		(setq ss_Mhide_25251325 nil)
	)	;progn
)
)
;==============================================
;;Bai 3: Lenh xoa tat ca doi tuong tren man hinh, chi de lai dong chu THIS IS A PRANK
;Sau do, yeu cau nguoi dung nhap dung chu Please thi tra va trang thai ban dau
(defun c:GAME( / cmd ss str)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget "X"))
(if ss 
	(progn
		(an ss)
		(entmake (list
			'(0 . "TEXT") 
			'(100 . "AcDbEntity") 
			'(100 . "AcDbText") 
			'(10 0 0) 
			(cons 40 (/ (getvar "viewsize") 12))
			'(1 . "THIS IS A PRANK") 
			(cons 72 1)
			(list 11 (car (setq tam (getvar "viewctr"))) (cadr tam)))
		) ;entmake
		(setq tbao (entlast))
		(while (or (not str) (/= str "Please")) (setq str (getstring "\nNhap dung chu: <Please>  de hien thi lai cong viec: ")))
		(if (= str "Please") (hien ss))
		(entdel tbao)
	) ;progn
) ;if
(setvar "cmdecho" cmd)
(princ)
)
;==================================================
;;Bai 4:
;Thu tuc nhap nhay 1 nhom doi tuong, trong do: Nhom doi tuong, so lan nhap nhay, toc do nhap nhay (lan/s)
;do nguoi dung chi dinh. Cuoi cung hien thi so doi tuong trong nhom, so lan nhay, thoi gian toi thieu thuc hien
;Quay ve man hinh ve neu nguoi dung an enter
(defun c:NHAY( / ss n v time cmd)
(prompt "\nChon doi tuong !")
(setq ss (ssget))
(if ss 
	(progn
		(setq cmd (getvar 'cmdecho))
		(setvar 'cmdecho 0)
		(setq n (getint "\nSo lan nhay:")
			  v (getreal "\nToc do nhay <lan/giay>:")
			  time (fix (/ 500 v )))
		(repeat n
			(MREDRAW ss 2)
			(command "delay" time)
			(MREDRAW ss 1)
			(command "delay" time)
		)
		(textscr)
		(command "delay" 1000)
		(princ (strcat "\nSo doi tuong da nhap nhay la: " (itoa (sslength ss)) " <doi tuong>"))
		(command "delay" 1000)
		(princ (strcat "\nSo lan nhay: " (itoa n) " <lan>"))
		(command "delay" 1000)
		(princ (strcat "\nToc do nhay: " (rtos v) " <lan/giay>"))
		(command "delay" 1000)
		(princ (strcat "\nThoi gian thuc hien: > " (itoa (* n 2 time)) " <mili giay>" ))
		(if (= "" (getstring "\n***Enter de quay tro lai man hinh ve !***")) (graphscr))
		(setvar 'cmdecho cmd)
		(princ)
	) ;progn
) ;if
)
;========================================================
;;Bai 5: Lenh highlight tat ca cac doi tuong co layer khac layer "0"
(defun c:HL(/ ss)
(setq ss (ssget "X" '((8 . "~0"))))
(if ss (MREDRAW ss 3))
)
;=======================================================================================
;********************************************
(defun MREDRAW (ss code / i ename)
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i))
	(redraw ename code)
) 	;repeat
)


<<

Filename: 311125_hhh_show_mhide_mshow_game_nhay_hl.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 332049
Tên lệnh: xcd
Nhờ viết lisp dim kích thước các pline và xuất ra file cel

Bác PhamThanhBinh ơi, em có đường 1 pline gồm n đoạn em muốn tick vào pline thì sẽ xuất chiều dài của n đoạn đó sang Exel được không ạ? Nhờ Bác viết giúp cho cái lisp nhé. Cảm ơn Bác.

 Tặng bạn. Lệnh xcd, line hay pline đều ok.

(defun c:xcd ( /...
>>

Bác PhamThanhBinh ơi, em có đường 1 pline gồm n đoạn em muốn tick vào pline thì sẽ xuất chiều dài của n đoạn đó sang Exel được không ạ? Nhờ Bác viết giúp cho cái lisp nhé. Cảm ơn Bác.

 Tặng bạn. Lệnh xcd, line hay pline đều ok.

(defun c:xcd ( / tapchon fn dt m )
	(setq	tapchon (ssget '((-4 . "<OR")
                         (0 . "LINE")
						 (-4 . "<AND") (0 . "LWPOLYLINE") (70 . 0)(-4 . "AND>")
						 (-4 . "OR>")))
			fn	(getfiled "Chon Noi Luu File" (getvar "dwgprefix") "csv" 1)
			fn	(open fn "w")
	)
	(repeat (sslength tapchon)
			(setq	dt (ssname tapchon 0)
					tapchon (ssdel dt tapchon)
					dt	(entget dt)
					dt	(vl-remove-if-not
										'(lambda (x) (or (= (car x) 10) (= (car x) 11) ) ) dt
						)
					m	0
			)
			(repeat	(1- (length dt) )
					(setq	chieudai (distance (cdr (nth m dt)) (cdr (nth (+ m 1) dt)))
							m	(1+ m)
					)
					(write-line (rtos chieudai 2 3) fn)			
			)
	)
	(close fn)
	(princ)	
)

<<

Filename: 332049_xcd.lsp
Tác giả: Tot77
Bài viết gốc: 331684
Tên lệnh: qq
Làm sao để xoay trục 180 độ mà text không bị ngược?

Cái này đúng hơn.

(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- xyz coordinate breakdown ----------------------
;;; This routine accepts a point from the calling function and breaks it down
;;; into X,Y values.
 
(defun get_xyz ( pt )
 (strcat "(" (rtos (* 0.001 (car pt)) 2 3) ";" (rtos (* 0.001 (cadr...
>>

Cái này đúng hơn.

(defun c:qq( / get-x get-y oce xp yp rwc )
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "luprec" 4)
(main)
(setvar "cmdecho" oce)
)
 
;;;----------------------------- xyz coordinate breakdown ----------------------
;;; This routine accepts a point from the calling function and breaks it down
;;; into X,Y values.
 
(defun get_xyz ( pt )
 (strcat "(" (rtos (* 0.001 (car pt)) 2 3) ";" (rtos (* 0.001 (cadr pt)) 2 3) ")"))
 
 
;;;-------------------Secondary main module------------------------------------
;;; Accepts the user input and allows the user to select many objects in
;;; succession.
 
(defun main()
(setvar 'dimzin 8)
(setq olddim (getvar "dimstyle") 
a (getreal (strcat "\n Input Text Height for Annotation <"
(if txtheight (rtos txtheight) (rtos (setq txtheight 2.5))) "> :"))
)
(if a (setq txtheight a))
(setvar 'dimtxt txtheight)
 
(while (setq rwc (getpoint "\nSelect point: "))
(setq xyp (get_xyz rwc)
rwc (trans rwc 1 0))
(command "ucs" "w")
 (command "_.leader" rwc pause "" xyp "")
 (command "ucs" "p")
)
(command "dimstyle" "restore" olddim)
)
 

<<

Filename: 331684_qq.lsp
Tác giả: pphung183
Bài viết gốc: 332454
Tên lệnh: td
Xin Lisp xuat toa độ

Chào a e diễn đàn cadviet.com

Hiện e đang cần gấp lisp td.lisp như trên nhưng có sửa chút ít.

Em muốn khi pick diểm chỉ hiện tên điểm chứ không hiện tọa độ và đường line.

Rất mong được mọi người giúp đỡ ạ!

Xem có đúng ý bạn ko :)

(defun...
>>

Chào a e diễn đàn cadviet.com

Hiện e đang cần gấp lisp td.lisp như trên nhưng có sửa chút ít.

Em muốn khi pick diểm chỉ hiện tên điểm chứ không hiện tọa độ và đường line.

Rất mong được mọi người giúp đỡ ạ!

Xem có đúng ý bạn ko :)

(defun C:td (/ om k h ten diem N)
(command "Undo" "Be") (setvar "cmdecho" 0) (setq om (getvar "osmode"))
(setq k 0 h (getreal "\nnhap chieu cao chu:")    
ten (getstring "\nNhap ten diem:")) (while  
(setq diem (getpoint "\nchon cac vi tri co toa do can ghi:"))  
(progn (setq k (+ 1 k) N (strcat ten (rtos k 2 0))) 
(setvar "osmode" 0) 
(command "circle" diem (* 1.8 h)) 
(entmake (list (cons 0 "TEXT") (cons 40 h) (cons 50 0) (cons 10 diem) (cons 1 N) (cons 72 4) (cons 11 diem) (cons 7 (getvar "Textstyle"))))
(setvar "osmode" om)	)) ;while  
(setvar "osmode" om ) (setvar "cmdecho" 1) (command "Undo" "E")  (princ))


<<

Filename: 332454_td.lsp
Tác giả: pphung183
Bài viết gốc: 332573
Tên lệnh: td
Xin Lisp xuat toa độ

Thử lại nhé :) !

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun textM (pt height string / lst) 
(setq lst (list '(0 . "TEXT") (cons 10 pt) (cons 40 height) (cons 1 string) (cons 50 0) (cons 72 4) (cons 11 pt) (cons 7 (getvar "Textstyle"))))
(entmakeX Lst)  )
(defun C:td (/ diem PT1 PT2 PT3 tapx tapy obj ss
		   x y xx yy h n di kc ten
		   C PT PTX PTY PTD PTC N
		   p1 p2 p3 p4 p11 p22 p33 L1 L2 L11...
>>

Thử lại nhé :) !

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun textM (pt height string / lst) 
(setq lst (list '(0 . "TEXT") (cons 10 pt) (cons 40 height) (cons 1 string) (cons 50 0) (cons 72 4) (cons 11 pt) (cons 7 (getvar "Textstyle"))))
(entmakeX Lst)  )
(defun C:td (/ diem PT1 PT2 PT3 tapx tapy obj ss
		   x y xx yy h n di kc ten
		   C PT PTX PTY PTD PTC N
		   p1 p2 p3 p4 p11 p22 p33 L1 L2 L11 L22)
(setvar "cmdecho" 0 )
(command "Undo" "Begin")  
  (setq om (getvar "osmode"))
  (setq tapx '()
	tapy '()
	stt '()
	k 0
	h (getreal "\nnhap chieu cao chu:")
	ten (getstring "\nNhap ten diem:"))
(while
  (setq diem (getpoint "\nchon cac vi tri co toa do can ghi:"))
	(setq   PT1 (list (+ (* 3 h) (car diem)) (+ (* 3 h) (cadr diem)))
		PT2 (list (car PT1) (- (cadr PT1)(+ 1 h) ) )
		 x (rtos(car diem) 2 4)
			 y (rtos (cadr diem) 2 4)
	   tapx (append tapx (list x))
	   tapy (append tapy (list y))
		 k (+ 1 k)
		 N (strcat ten (rtos k 2 0))
		stt (append stt (list N))
	  );setq
  (setvar "osmode" 0)
(setq obj (textM pt1 h x)) (setq ss (entlast)) 
;(command "text" "j" "BL" PT1 h 0 x)
(setq TB (textbox (entget ss)) 
LC (car TB) RC (cadr TB) di (distance LC RC) PT3 (polar PT1 0 (+ di h)) C (polar PT3 0 (* 1.8 h)));setq
(command "erase" ss "" "pline" diem PT1 PT3 ""
		 "circle" C (* 1.8 h))
		 (textM C h N) 
	(setvar "osmode" om)	);dong while
;tao bang thong ke
(setq	kc (* 2 di)
	PT (getpoint"\nvi tri dat bang :")
	PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	p1 (list (car PT) (+ (cadr PT)(* 2 h)))
	p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
	p3 (list (car p1) (+ (cadr p1)(* 2 h)))
	p4 (list (car p2) (+ (cadr p2)(* 2 h)))
	PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
	PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
	PTY (list (+ kc (car PTX)) (cadr PTX))
	  p11 (list (+ (/ di 2) (car p1))  (+ h (cadr p1)))
	  p22 (list (+ di (/ di 2) (car p11)) (cadr p11))
	  p33 (list (+ kc (car p22)) (cadr p22))
	  L1 (list (+ di (car p3))(cadr p3))
	  L2 (list (+ kc (car L1))(cadr L1))
	 n (length tapx)
	 k 0);setq
(setvar "osmode" 0)
  (command "line" p1 p2 "" "line" p3 p4 "")
	   (textM p11 h "STT") ;"text" "j" "m" p11 h 0 "STT" 
	   (textM p22 h "T\U+1ECDa \U+0111\U+1ED9 X") ;"text" "j" "m" p22 h 0 "Täa ®é X"
	   (textM p33 h "T\U+1ECDa \U+0111\U+1ED9 Y") ;"text" "j" "m" p33 h 0 "Täa ®é Y"
  (while (< k n) 
	(setq xx (nth k tapx)
	  yy (nth k tapy)
	 tstt(nth k stt))
		 (textM PTD h tstt) ;"text" "j" "m" PTD h 0 tstt 
		 (textM PTX h xx) ;"text" "j" "m" PTX h 0 xx 
		 (textM PTY h yy) ;"text" "j" "m" PTY h 0 yy 
		(command "line" PT PTC "")	
	(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
		 PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	 PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
	 PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
	 PTY (list (+ kc (car PTX)) (cadr PTX))
	  k (+ 1 k))	);while
  (if (= k n)
	(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
	  PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	  L11 (list (+ di (car PT))(cadr PT))
	  L22 (list (+ kc (car L11))(cadr L11)))	);if
(command "line" p3 PT ""
	  "line" p4 PTC ""
	  "line" L1 L11 ""
	  "line" L2 L22 "")
(setvar "osmode" om ) (setvar "cmdecho" 1)
  (command "Undo" "End")  (princ))

<<

Filename: 332573_td.lsp
Tác giả: pphung183
Bài viết gốc: 332579
Tên lệnh: td
Xin Lisp xuat toa độ

Lần cuối nhé <_< !

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun textM (pt height string / lst) 
(setq lst (list '(0 . "TEXT") (cons 10 pt) (cons 40 height) (cons 1 string) (cons 50 0) (cons 72 4) (cons 11 pt) (cons 7 (getvar "Textstyle"))))
(entmakeX Lst)  )
(defun C:td (/ diem PT1 tapx tapy obj ss
		   x y xx yy h n di kc ten
		   C PT PTX PTY PTD PTC N
		   p1 p2 p3 p4 p11 p22 p33 L1 L2 L11...
>>

Lần cuối nhé <_< !

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun textM (pt height string / lst) 
(setq lst (list '(0 . "TEXT") (cons 10 pt) (cons 40 height) (cons 1 string) (cons 50 0) (cons 72 4) (cons 11 pt) (cons 7 (getvar "Textstyle"))))
(entmakeX Lst)  )
(defun C:td (/ diem PT1 tapx tapy obj ss
		   x y xx yy h n di kc ten
		   C PT PTX PTY PTD PTC N
		   p1 p2 p3 p4 p11 p22 p33 L1 L2 L11 L22)
(setvar "cmdecho" 0 )
(command "Undo" "Begin")  
  (setq om (getvar "osmode"))
  (setq tapx '()
	tapy '()
	stt '()
	k 0
	h (getreal "\nnhap chieu cao chu:")
	ten (getstring "\nNhap ten diem:"))
(while
  (setq diem (getpoint "\nchon cac vi tri co toa do can ghi:"))
	(setq   PT1 (polar diem (/ pi 1.8) (* 1.2 h))
		;PT2 (list (car PT1) (- (cadr PT1) (+ 1 h) ) )
		 x (rtos(car diem) 2 4)
			 y (rtos (cadr diem) 2 4)
	   tapx (append tapx (list x))
	   tapy (append tapy (list y))
		 k (+ 1 k)
		 N (strcat ten (rtos k 2 0))
		stt (append stt (list N))
	  );setq
  (setvar "osmode" 0)
(setq obj (textM pt1 h x)) (setq ss (entlast)) 
;(command "text" "j" "BL" PT1 h 0 x)
(setq TB (textbox (entget ss)) 
LC (car TB) RC (cadr TB) di (distance LC RC) C (polar diem (/ pi 1.8) (* 3 h)));setq
(command "erase" ss "" "pline" diem PT1 ""
		 "circle" C (* 1.8 h))
		 (textM C h N) 
	(setvar "osmode" om)	);dong while
;tao bang thong ke
(setq	kc (* 2 di)
	PT (getpoint"\nvi tri dat bang :")
	PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	p1 (list (car PT) (+ (cadr PT)(* 2 h)))
	p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
	p3 (list (car p1) (+ (cadr p1)(* 2 h)))
	p4 (list (car p2) (+ (cadr p2)(* 2 h)))
	PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
	PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
	PTY (list (+ kc (car PTX)) (cadr PTX))
	  p11 (list (+ (/ di 2) (car p1))  (+ h (cadr p1)))
	  p22 (list (+ di (/ di 2) (car p11)) (cadr p11))
	  p33 (list (+ kc (car p22)) (cadr p22))
	  L1 (list (+ di (car p3))(cadr p3))
	  L2 (list (+ kc (car L1))(cadr L1))
	 n (length tapx)
	 k 0);setq
(setvar "osmode" 0)
  (command "line" p1 p2 "" "line" p3 p4 "")
	   (textM p11 h "STT") ;"text" "j" "m" p11 h 0 "STT" 
	   (textM p22 h "T\U+1ECDa \U+0111\U+1ED9 X") ;"text" "j" "m" p22 h 0 "Täa ®é X"
	   (textM p33 h "T\U+1ECDa \U+0111\U+1ED9 Y") ;"text" "j" "m" p33 h 0 "Täa ®é Y"
  (while (< k n) 
	(setq xx (nth k tapx)
	  yy (nth k tapy)
	 tstt(nth k stt))
		 (textM PTD h tstt) ;"text" "j" "m" PTD h 0 tstt 
		 (textM PTX h xx) ;"text" "j" "m" PTX h 0 xx 
		 (textM PTY h yy) ;"text" "j" "m" PTY h 0 yy 
		(command "line" PT PTC "")	
	(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
		 PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	 PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
	 PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
	 PTY (list (+ kc (car PTX)) (cadr PTX))
	  k (+ 1 k))	);while
  (if (= k n)
	(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
	  PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
	  L11 (list (+ di (car PT))(cadr PT))
	  L22 (list (+ kc (car L11))(cadr L11)))	);if
(command "line" p3 PT ""
	  "line" p4 PTC ""
	  "line" L1 L11 ""
	  "line" L2 L22 "")
(setvar "osmode" om ) (setvar "cmdecho" 1)
  (command "Undo" "End")  (princ))

<<

Filename: 332579_td.lsp

Trang 188/330

188