[Yêu cầu] Lisp kết hợp lệnh Array và Copy

Tháng 3 28, 2013

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả Text (Mtext). Riêng Text chứa số thì có thể tăng/giảm theo gia số, nó chấp nhận cả số có tiền và/hoặc hậu tố.

Nếu có nhiều Text số được chọn thì chỉ 1 Text số chọn sau cùng được tăng/giảm. Số chữ số thập phân (nếu có) sẽ lấy theo Text chọn.

; Doan Van Ha CADViet.com
; Copy-Array cac doi tuong ke ca Text (Mtext), rieng Text co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
; P/S (01-03-2012): bo sung them so chu so 0 dau num de phu hop voi text mau. VD: "CN: 01" tang thanh "CN: 02"...
(defun C:CA (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
 (vl-load-com)
 (command "undo" "be")
 (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (princ "\nChon cac doi tuong can Copy-Array...")
 (setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
       	dt1 dt p1 (getpoint "\nDiem goc: ") p2 (getpoint p1 "\nDiem den: ") sl (getint "\nSo lan: ") x 1)
 (setvar "osmode" 0) (setvar "cmdecho" 0)
 (foreach n dsdt
  (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
   (if (KT_NUM (cdr (assoc 1 (entget n))))
	(setq dt2 n))))
 (if dt2 (setq dt1 (ssdel dt2 dt)))
 (if dt2
  (progn
   (initget "Y N")
   (setq kwrd (getkword "\nBan muon Text tang dan ? [Y/<N>]  ") giaso (getreal "\nGia so: "))
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(if (eq kwrd "Y")
 	(progn
  	(CHIA3 (cdr (assoc 1 (entget dt2))))
  	(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
  	(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
  	(entupd (entlast))))
	(setq x (1+ x)))))
 (if dt1
  (progn
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(setq x (1+ x)))))
 (command "undo" "e")
 (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
 (setq lstt (vl-string->list str) lstn (reverse lstt))
 (while lstt
  (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
         	(T (setq lstt nil))))
 (while lstn
  (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
         	(T (setq lstn nil))))
 (setq ds (list (vl-list->string (reverse trai))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
 (foreach n (vl-string->list str)
  (if (and (>= n 48) (<= n 57)) (setq kt T)))
 kt)
 ;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
 (setq m 0)
 (while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
  (setq m (1+ m) str (substr str 2)))
 m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
 (while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
  (setq strs (strcat "0" strs)))
 strs)

P/S: sửa 07/02/2012 để không còn dùng các hàm Acet.

P/S: sửa 01/03/2012 để thêm số chữ số 0 vào đầu Num của Text để phù hợp với Text gốc.

Chào bác Doan Van Ha! Không biết bác có còn theo dõi topic này nữa không. Nếu bác còn theo dõi thì giải quyết giúp tôi vấn đề này với. Tôi đã dowload lisp của bác về dùng. Lisp dùng rất hay và đáp ứng được nhu cầu sử dụng của tôi. Nhưng tôi muốn thay đổi việc "nhập hai điểm đầu tiên là khoảng cách các text và nhập số lần là số text cần copy" bằng việc "nhập hai điểm đầu tiên là khoảng mà text sẽ copy(ví dụ trong khoảng 100m) và chọn hai điểm tiếp theo để lấy khoảng cách giữa hai text(ví dụ là 1m). Tôi thấy làm như thế thì sẽ tiện hơn khi sử dụng(theo tôi là như vậy). Tôi có sưu tầm được một lisp copy và array như thế, nhưng nó không tăng được số. Đây là lisp tôi đang sử dụng http://www.cadviet.com/upfiles/3/67165_copyarray.lsp

Rất cám ơn bác về lisp của bác!

Tháng 3 28, 2013

Bạn thay đoạn này:

(getint "\nSo lan: ")

Bằng đoạn này:

(fix (+ (/ (distance p1 (getpoint "\nDiem den cuoi cung: ")) (distance p1 p2)) 1))

Chú ý: để chính xác thì 2 khoảng cách chia nhau phải ra 1 số nguyên.

Tháng 3 28, 2013

Bạn thay đoạn này:

(getint "\nSo lan: ")

Bằng đoạn này:

(fix (+ (/ (distance p1 (getpoint "\nDiem den cuoi cung: ")) (distance p1 p2)) 1))

Chú ý: để chính xác thì 2 khoảng cách chia nhau phải ra 1 số nguyên.

Cám ơn bác đã hồi đáp! Tôi đã làm theo như thế nhưng vẫn không được, tôi không hiểu nhiều vì lisp, mong bác giúp cho!

Tháng 3 21, 2014

Các cao thủ thật là tuyệt vời!

Mong các bác luôn chia sẻ và cống hiến để bọn em học hỏi!

Tháng 5 9, 2016

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả Text (Mtext). Riêng Text chứa số thì có thể tăng/giảm theo gia số, nó chấp nhận cả số có tiền và/hoặc hậu tố.

Nếu có nhiều Text số được chọn thì chỉ 1 Text số chọn sau cùng được tăng/giảm. Số chữ số thập phân (nếu có) sẽ lấy theo Text chọn.

; Doan Van Ha CADViet.com
; Copy-Array cac doi tuong ke ca Text (Mtext), rieng Text co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
; P/S (01-03-2012): bo sung them so chu so 0 dau num de phu hop voi text mau. VD: "CN: 01" tang thanh "CN: 02"...
(defun C:CA (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
 (vl-load-com)
 (command "undo" "be")
 (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (princ "\nChon cac doi tuong can Copy-Array...")
 (setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
       	dt1 dt p1 (getpoint "\nDiem goc: ") p2 (getpoint p1 "\nDiem den: ") sl (getint "\nSo lan: ") x 1)
 (setvar "osmode" 0) (setvar "cmdecho" 0)
 (foreach n dsdt
  (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
   (if (KT_NUM (cdr (assoc 1 (entget n))))
	(setq dt2 n))))
 (if dt2 (setq dt1 (ssdel dt2 dt)))
 (if dt2
  (progn
   (initget "Y N")
   (setq kwrd (getkword "\nBan muon Text tang dan ? [Y/<N>]  ") giaso (getreal "\nGia so: "))
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(if (eq kwrd "Y")
 	(progn
  	(CHIA3 (cdr (assoc 1 (entget dt2))))
  	(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
  	(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
  	(entupd (entlast))))
	(setq x (1+ x)))))
 (if dt1
  (progn
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(setq x (1+ x)))))
 (command "undo" "e")
 (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
 (setq lstt (vl-string->list str) lstn (reverse lstt))
 (while lstt
  (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
         	(T (setq lstt nil))))
 (while lstn
  (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
         	(T (setq lstn nil))))
 (setq ds (list (vl-list->string (reverse trai))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
 (foreach n (vl-string->list str)
  (if (and (>= n 48) (<= n 57)) (setq kt T)))
 kt)
 ;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
 (setq m 0)
 (while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
  (setq m (1+ m) str (substr str 2)))
 m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
 (while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
  (setq strs (strcat "0" strs)))
 strs)

P/S: sửa 07/02/2012 để không còn dùng các hàm Acet.

P/S: sửa 01/03/2012 để thêm số chữ số 0 vào đầu Num của Text để phù hợp với Text gốc.

Xin lỗi vì đã up lại bài viết cũ. Cảm ơn bác rất nhiều ạ,em muốn không có hộp thoại"Bạn có muốn Text tăng dần" mà mặc định nó luôn là Yes thì thay lệnh ntn ạ,em mò hổi mà k ra vì e k biết gì về lập trình. Cảm ơn bác

Tháng 2 8, 2018

Vào lúc 19/9/2011 tại 22:07, Doan Van Ha đã nói:

Đây chắc đúng y/c của bạn.

ca.lsp
[✎]


;Doan Van Ha
(defun C:CA (/ dt dsdt dt1 dt2 p1 p2 sl x)
(command "undo" "be")
(setq osm (getvar "osmode"))
(princ "\nChon cac doi tuong can Copy-Array...")
(setq dsdt (acet-ss-to-list (setq dt (ssget)))
       	p1 (getpoint "\nDiem goc: ")
       	p2 (getpoint p1 "\nDiem den: ")
       	sl (getint "\nSo lan: ")
       	x 1)
(foreach n dsdt
 (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
  (setq dt1 (ssdel n dt) dt2 n)))
(setvar "osmode" 0)
(repeat sl
 (command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
 (command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
 (entmod (subst (cons 1 (itoa (+ (atoi (cdr (assoc 1 (entget dt2)))) x))) (assoc 1 (entget (entlast))) (entget (entlast))))
 (entupd (entlast))
 (setq x (1+ x)))
(command "undo" "e")
(setvar "osmode" osm)
(princ))

Nhờ các bác tối ưu dùm em code này với, em là binh nhì nên còn non kém.
;; free lisp from cadviet.com
;;; Downloaded from https://www.cadviet.com/forum/topic/54624-yêu-cầu-lisp-kết-hợp-lệnh-array-và-copy/
(defun C:CA (/ dt p1 p2 sl s2 i )
(command "undo" "be")
(setq osm (getvar "osmode"))
(setq dt (ssget)
   p1    (getpoint "\nDiem goc: ")
   p2   (getpoint p1 "\nDiem den: ")
   sl    (getint "\nSo lan: ")
   s2    (/ (distance p1 p2) sl)
   i 1
   )
(setvar "osmode" 0)
(repeat sl
(command ".copy" dt "" p1 (polar p1 (angle p1 p2) s2 ))
(Setq s2    (/ (distance p1 p2) sl))
(setq i (+ 1 i))
(setq s2 (* i s2))
);----------------------------------DONG HAM REPEAT
(command "undo" "e")
(setvar "osmode" 1023)
(princ))

Tháng 2 8, 2018

2 giờ trước, CuongXD7 đã nói:

Nhờ các bác tối ưu dùm em code này với, em là binh nhì nên còn non kém.
;; free lisp from cadviet.com
;;; Downloaded from https://www.cadviet.com/forum/topic/54624-yêu-cầu-lisp-kết-hợp-lệnh-array-và-copy/
(defun C:CA (/ dt p1 p2 sl s2 i )
(command "undo" "be")
(setq osm (getvar "osmode"))
(setq dt (ssget)
   p1    (getpoint "\nDiem goc: ")
   p2   (getpoint p1 "\nDiem den: ")
   sl    (getint "\nSo lan: ")
   s2    (/ (distance p1 p2) sl)
   i 1
   )
(setvar "osmode" 0)
(repeat sl
(command ".copy" dt "" p1 (polar p1 (angle p1 p2) s2 ))
(Setq s2    (/ (distance p1 p2) sl))
(setq i (+ 1 i))
(setq s2 (* i s2))
);----------------------------------DONG HAM REPEAT
(command "undo" "e")
(setvar "osmode" 1023)
(princ))

Tối ưu cái gì? Câu hỏi quá tối nghĩa, xứng đáng nhận 1 điểm trừ

Tháng 2 9, 2018

10 giờ trước, Doan Van Ha đã nói:

Tối ưu cái gì? Câu hỏi quá tối nghĩa, xứng đáng nhận 1 điểm trừ

Ở cái dòng code màu cam đó anh, em không biết viết sao cho gọn hơn.
Code chạy thì được rồi nhưng thuật toán còn rườm rà, em nhờ các anh sửa gọn lại dùm em chút xíu.

Tháng 2 9, 2018


(defun C:CA (/ dt p1 p2 sl s2 i )
 (command "undo" "be")
 (setq osm (getvar "osmode"))
 (setq dt (ssget)
       p1 (getpoint "\nDiem goc: ")
       p2 (getpoint p1 "\nDiem den: ")
       sl (getint "\nSo lan: ")
       s2 (/ (distance p1 p2) sl)
       i 1)
 (setvar "osmode" 0)
 (repeat sl
  (command ".copy" dt "" p1 (polar p1 (angle p1 p2) (* i s2)))
  (setq i (1+ i)))
 (command "undo" "e")
 (setvar "osmode" 1023)
 (princ))

Tháng 2 11, 2018

Vào lúc 9/2/2018 tại 09:13, Doan Van Ha đã nói:


(defun C:CA (/ dt p1 p2 sl s2 i )
 (command "undo" "be")
 (setq osm (getvar "osmode"))
 (setq dt (ssget)
       p1 (getpoint "\nDiem goc: ")
       p2 (getpoint p1 "\nDiem den: ")
       sl (getint "\nSo lan: ")
       s2 (/ (distance p1 p2) sl)
       i 1)
 (setvar "osmode" 0)
 (repeat sl
  (command ".copy" dt "" p1 (polar p1 (angle p1 p2) (* i s2)))
  (setq i (1+ i)))
 (command "undo" "e")
 (setvar "osmode" 1023)
 (princ))

Cám ơn anh nhé, đơn giản như vậy mà em mò mấy tiếng chưa được ^^

Đăng nhập

[Yêu cầu] Lisp kết hợp lệnh Array và Copy

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

kimvantoan 0

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

Doan Van Ha 3.191

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

kimvantoan 0

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

thai11000 4

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

vuvu93 1

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

CuongXD7 3

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

Doan Van Ha 3.191

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

CuongXD7 3

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

Doan Van Ha 3.191

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

CuongXD7 3

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

Tạo tài khoản

Đăng nhập

Diễn đàn

Download

Đào tạo CADViet

Browse