Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
nhimret

[Nhờ chính sửa] Lisp tịnh tiến số + chữ

Các bài được khuyến nghị

 Kính nhờ các bác chỉnh sửa hộ lisp này với :) cám ơn trước đã

 

Triệu chứng: Lisp hiện giờ tịnh tiến rất tốt, nhưng cứ ở hàng chục có số 0, thì lisp bỏ mất số 0 mà chỉ tịnh tiến số sau (VD: 01 tịnh tiến thành 2, 101 tịnh tiến thành 12)

 

Yêu cầu: nhờ các bác chỉnh lại hộ sao cho 01 --> 02 --> 03, 101 -> 102 -> 103 v.v...

 

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

 

p/s: lisp cũng lấy ở forum thời gian rất lâu rồi nên không nhớ được tác giả là ai, xin lỗi bác tác giả trước không ghi credit nhé <3

(defun xulytext (text / kytu ma sokt luusokt lui )
(setq 	kytu	(substr text (strlen text))
		ma	(ascii kytu)
		sokt	(read kytu) 
		lui	1
)
(if (numberp sokt)
		(progn
			(setq luusokt	(1+ sokt))
			(if (and 	(numberp sokt) 
					(> (strlen text) 1)
			    )	
			   (progn
				(setq 	kytu	(substr text (1- (strlen text)))
						sokt	(read kytu) 
										)
				(if 	(numberp sokt) 
					(setq luusokt (1+	sokt)
							lui 	2

						)
				)
			    );progn	
			)
			(if (= luusokt	100)	(setq 	luusokt	0))
			(setq 	kytu		(rtos luusokt 2 0)
					
					text	(strcat	(substr text 1 (- (strlen text) lui))  kytu)
			)
		);progn			 
		(if   (or 	(= kytu "z")
				(= kytu "Z")
			)
			(setq 	text		(strcat 	text	"0")
				textxl		"0"
			)
			(setq		ma	(1+	ma)
					text	(strcat	(substr text 1 (1- (strlen text)))  (chr ma))
			)
		);if
);if
)
;*********************************************************************
(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)
;Neu doi tuong la text thi tiep tuc
(setq 	doituong 	(entget  tendoituong)
	kieu		(cdr (assoc 	0	doituong))
	canle		(cdr (assoc 	72	doituong))
)	
(if (or (= kieu		"TEXT")
	(= kieu 	"MTEXT")	
    ) 	
	(progn
		(setq	textxl	(xulytext textxl)
			text	(cons 1 textxl)
			vitri10 	(cdr (assoc 10 doituong))
			vitri10 	(list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))
			vitri10		(cons 10 vitri10)
			vitri11 	(cdr (assoc 11 doituong))
			vitri11 	(list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))
			vitri11		(cons 11 vitri11)
			dem	0
			dsach	nil
		)
		(foreach tam 	doituong
			(cond
				((= (car tam)	1)	(setq dsach 	(append dsach (list text))))
				((= (car tam)	10)	(setq dsach 	(append dsach (list vitri10))))
				((= (car tam)	11)	(setq dsach 	(append dsach (list vitri11))))
				((setq dsach 	(append dsach (list tam))))
			)
		)
		(entmake dsach)
	);progn
);if
	);
;*********************************************************************
;sao doi tuong cu sang vi tri moi

(defun copy_dt (tendoituong )
(command "copy" tendoituong "" goc toi )
);defun
;*********************************************************************

(defun c:44 ( / cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
(princ "\nCopy Inteligent...\n")
(setq 	luuecho	(getvar	"cmdecho")
	luu	*error*
	*error*	ketthuc
	cumdt 	(ssget)
	dodai 	(sslength cumdt)
	goc		(getpoint "\nSelect base point:")
	thoat		nil
	dem		0
	textxl		nil
);
(setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
(while	(and 	(= thoat	nil)
		(< dem	dodai)
	)
	(setq 	ten	(ssname cumdt dem)
		dem	(1+ 	dem)
		doituong (entget ten)
		kieu	 (cdr (assoc 	0	doituong))			
	)
	
	(if (or (= kieu		"TEXT")
		(= kieu 	"MTEXT")	
    	    )
		(setq 	thoat	T
			textxl 	(cdr (assoc 1 doituong)) 	
		)
	)
);
(while T 
(setq	toi		(getpoint "\nSelect next point: " goc)
	vitrilech 	(list 	(- (car toi) (car goc)) (- (nth 1 toi) (nth 1 goc)))
	dem		0
)
(while	(< dem dodai)
	(setq 	ten	(ssname cumdt dem)
		dem	(1+ 	dem)
		doituong (entget ten)
		kieu	 (cdr (assoc 	0	doituong))			
	)

	(if (or (= kieu		"TEXT")
		(= kieu 	"MTEXT")	
    	    )
		(doitext	ten)
		(copy_dt	ten)

	);if
)
);while
(ketthuc)
);defun

;Note: bien toan cuc: textxl vitrilech

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

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình nhanh cho Bạnhttp://www.cadviet.com/upfiles/4/3202_44.lsp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/128171-nha-cha-nh-sa-a-lisp-ta-nh-tia-n-sa-cha/
(defun xulytext (text / kytu ma sokt luusokt lui )
(setq 	kytu	(substr text (strlen text))
		ma	(ascii kytu)
		sokt	(read kytu) 
		lui	1
)
(if (numberp sokt)
		(progn
		  (setq luusokt (1+ (read text)))
      (setq text (rtos luusokt 2 0))
			;|(setq luusokt	(1+ sokt))
		  
			(if (and 	(numberp sokt) 
					(> (strlen text) 1)
			    )	
			   (progn
				(setq 	kytu	(substr text (1- (strlen text)))
						sokt	(read kytu) 
										)
				(if 	(numberp sokt) 
					(setq luusokt (1+	sokt)
							lui 	2

						)
				)
			    );progn	
			)
			;(if (= luusokt	100)	(setq 	luusokt	0))
			(setq 	kytu		(rtos luusokt 2 0)
					
					text	(strcat	(substr text 1 (- (strlen text) lui))  kytu)
			)|;
		);progn			 
		(if   (or 	(= kytu "z")
				(= kytu "Z")
			)
			(setq 	text		(strcat 	text	"0")
				textxl		"0"
			)
			(setq		ma	(1+	ma)
					text	(strcat	(substr text 1 (1- (strlen text)))  (chr ma))
			)
		);if
);if
)
;*********************************************************************
(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)
;Neu doi tuong la text thi tiep tuc
(setq 	doituong 	(entget  tendoituong)
	kieu		(cdr (assoc 	0	doituong))
	canle		(cdr (assoc 	72	doituong))
)	
(if (or (= kieu		"TEXT")
	(= kieu 	"MTEXT")	
    ) 	
	(progn
		(setq	textxl	(xulytext textxl)
			text	(cons 1 textxl)
			vitri10 	(cdr (assoc 10 doituong))
			vitri10 	(list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))
			vitri10		(cons 10 vitri10)
			vitri11 	(cdr (assoc 11 doituong))
			vitri11 	(list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))
			vitri11		(cons 11 vitri11)
			dem	0
			dsach	nil
		)
		(foreach tam 	doituong
			(cond
				((= (car tam)	1)	(setq dsach 	(append dsach (list text))))
				((= (car tam)	10)	(setq dsach 	(append dsach (list vitri10))))
				((= (car tam)	11)	(setq dsach 	(append dsach (list vitri11))))
				((setq dsach 	(append dsach (list tam))))
			)
		)
		(entmake dsach)
	);progn
);if
	);
;*********************************************************************
;sao doi tuong cu sang vi tri moi

(defun copy_dt (tendoituong )
(command "copy" tendoituong "" goc toi )
);defun
;*********************************************************************

(defun c:44 (/ cumdt dodai thoat dem ten doituong textxl dem goc toi)
					; Khoi dau cua chuong trinh
  (princ "\nCopy Inteligent...\n")
  (setq	luuecho	(getvar "cmdecho")
	luu	*error*
	*error*	ketthuc
	cumdt	(ssget)
	dodai	(sslength cumdt)
	goc	(getpoint "\nSelect base point:")
	thoat	nil
	dem	0
	textxl	nil
  )					;
  (setvar "cmdecho" 0)
					; Loc ra duoc ong text de xu ly
  (while (and (= thoat nil)
	      (< dem dodai)
	 )
    (setq ten	   (ssname cumdt dem)
	  dem	   (1+ dem)
	  doituong (entget ten)
	  kieu	   (cdr (assoc 0 doituong))
    )

    (if	(or (= kieu "TEXT")
	    (= kieu "MTEXT")
	)
      (setq thoat  T
	    textxl (cdr (assoc 1 doituong))
      )
    )
  )					;
  (while 
    (setq toi	    (getpoint "\nSelect next point: " goc))
	  (setq
	  vitrilech (list (- (car toi) (car goc))
			  (- (nth 1 toi) (nth 1 goc))
		    )
	  dem	    0
    )
    (while (< dem dodai)
      (setq ten	     (ssname cumdt dem)
	    dem	     (1+ dem)
	    doituong (entget ten)
	    kieu     (cdr (assoc 0 doituong))
      )

      (if (or (= kieu "TEXT")
	      (= kieu "MTEXT")
	  )
	(doitext ten)
	(copy_dt ten)

      )					;if
    )
  )					;while
  (ketthuc)
)					;defun

;Note: bien toan cuc: textxl vitrilech

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

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×