[Đã xong] Dynamic LArray

[ketxu 2.984]

@Ketxu 21-9-11

Lisp copy array (chính xác hơn là multi copy ^^) các đối tượng theo 1 đường thẳng, cho phép cộng có gia số với Text đánh số

Có phân biệt số INT hoặc REAL. Mặc định để 1 số thập phân và lựa chọn Không tăng khi tập chọn có TEXT :)

Update 1.2 : Cho phép xử lý với cả các Text có format [Tiền tố] số [Hậu tố]

 

 

 

Open source :

;Dynamic Array v1.2 Ketxu 21 - 9 -11
;Many thank to quichen's code
(vl-load-com)
(defun c:dar( / dir gr nx p0 px pxv ssFull ss1 vecx ans inc)
(grtext -1 "Dynamic LArray @Ketxu")
(setq m:err *error*	*error* err)
(command "undo" "be")
(if (setq ssFull (ST:SS->List-Vla (ssget))
 	  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
 (cond ((ST:Check-Exist '("AcDbText" "AcDbMText") (mapcar 'vla-get-objectname ssFull))    
 (setq ans (strcase(getstring "Copy t\U+0103ng Text ? < K > :")))
  (cond ((not (or (= ans "K")(= ans "")))
(or #num (setq #num 1))
(setq #num (cond ((getint (strcat "\nGia s\U+1ED1 < " (rtos #num 2 0) " > :")))(#num)) inc T)
)
  )
 )
 )  
 (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 inc #num))
(grdraw p0 (mapcar '+ p0 pxv) 3 1)
 )
)
)
(command "undo" "en")
 (princ)
)
(defun ST:Ss-Copy-Dynamic (sslst n v dir inc num / i number matlist obj1 ss transmat xobj isText lst isReal)
 (setq ss (ssadd))
 (foreach xobj sslst
(setq i 1)
(cond ((and (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
(cond ((= 'REAL (type (setq number (cadr (setq lst (txt2num (vla-get-textstring xobj)))))))
 	  (setq  isReal T))
 	(T (setq  isReal nil))
)
(setq isText T)
  ) ;Text Object
(T setq isText nil)
)  
(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") inc num)
  	 (vla-put-textstring obj1 (strcat (car lst) (rtos (setq number (+ num number)) 2  (if isReal 1 0))(last lst))))
 	(ssadd (vlax-vla-object->ename obj1) ss)
 	(setq i (1+ i))
)
 )
 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 err (msg)    
   (if ss1 (ST:ss-delete ss1))
   (setq *error* m:err 		  m:err nil
   )
 )
(defun txt2num (str / num pos)
(setq pos (vl-string-search (setq num (vl-list->string (vl-remove-if-not '(lambda (x) (or (< 44 x 47)(< 47 x 58)))(vl-string->list str))))str))
(list
   (substr str 1  pos)
   (if (vl-string-search "." num)(atof num)(atoi num))
   (substr str (+ 1 pos (strlen num)))
))

[matden_304 0]

Đúng theo phong cách của Lee, rất tuyệt, mà có 2 chỗ này cần chỉnh lại xíu nè. Cái chỗ Hướng và khoảng cách copy: Chọn đối tượng có text, bạn có muốn copy tăng nó không. Dòng đó dài quá, nên mình gõ chọn nó không hiển thị hết trên dòng command. Nên rút ngắn lại xíu, như là Text có tăng giảm hay ko?. Vì cái dòng này chỉ hiển thị với đối tượng là text nên chỉ vậy là đủ ( Em tìm trong cái dòng này trong code để chỉnh sửa mà ko thấy. Chắc gà quá :D )

Thứ nữa là đang kéo chuột mà mình nhấn ESC thì thoát lệnh chứ không phải là kết thúc lệnh. Lệnh chỉ kết thúc khi bấm chuột trái mà thôi.

Thanks anh Ketxu rất nhiều

[ketxu 2.984]

Đúng theo phong cách của Lee, rất tuyệt, mà có 2 chỗ này cần chỉnh lại xíu nè. Cái chỗ Hướng và khoảng cách copy: Chọn đối tượng có text, bạn có muốn copy tăng nó không. Dòng đó dài quá, nên mình gõ chọn nó không hiển thị hết trên dòng command. Nên rút ngắn lại xíu, như là Text có tăng giảm hay ko?. Vì cái dòng này chỉ hiển thị với đối tượng là text nên chỉ vậy là đủ ( Em tìm trong cái dòng này trong code để chỉnh sửa mà ko thấy. Chắc gà quá :D )

Thứ nữa là đang kéo chuột mà mình nhấn ESC thì thoát lệnh chứ không phải là kết thúc lệnh. Lệnh chỉ kết thúc khi bấm chuột trái mà thôi.

Thanks anh Ketxu rất nhiều

Đỏ : câu thông báo đó nằm ở dòng này, bạn tự sửa theo ý thích nhé :(vì dùng Unicode Hexa font nên có thể bạn thấy khó đọc :) )

(setq ans (strcase(getstring "T\U+1EADp ch\U+1ECDn c\U+00F3 \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Text, b\U+1EA1n c\U+00F3 mu\U+1ED1n copy t\U+0103ng n\U+00F3 kh\U+00F4ng ? < K > :")))

Nhớ là ở bước này, nếu bạn nhấn Space luôn thì lisp lấy mặc định là copy bình thường (không tăng)

Xanh : có lẽ là phải thêm hàm error, để mình xem có được không

P/s : thêm 1 lời khuyên là hãy luôn dùng chế độ Dynamic Input để đọc cho sướng ^^

 

Ok, xanh đã tạm được. Bạn chú ý ngắt hàm bằng ESC thôi nhé :)

[matden_304 0]

Cái text có số đếm anh chỉnh lại sao nó ko giữ nguyên chữ nhỉ. VD như là Phòng 1 - > Phòng 2 -> Phòng 3....

Cái lisp anh send mới nhất thì nó chỉ là Phòng 1 -> 2 ->3...

Cái phím bấm esc thì ok rồi, mà anh cải tiến hơn chút nữa đi, Khi bấm esc thì nó giữ nguyên trỏ chuột tại vị trí nó đang đứng chứ ko trả về vị trí ban đầu khi khởi động. ^^^^^^:wub::wub:

[ketxu 2.984]

@matden : Mình đã nói là chưa phân biệt được chữ cái với text số mà :)

phòng 1 -> phòng 2 -> phòng 3 .... nó lại là một chuyện khác, và nó cần nhiều hơn vài đoạn code như ket đã giới thiệu :) Hơn nữa, giả sử, mình làm xong rồi, hôm sau lại có bạn hỏi 1 người -> 2 người -> 3 người.... hôm sau nữa lại có người hỏi Phòng ngủ A -> phòng ngủ B.....=> vậy phải làm sao ????

Để thực hiện việc này tốt nhất bạn sử dụng riêng biệt các lisp copy text, hoặc đừng copy tăng nữa, sử dụng lisp này xong thì dùng Tcount

P/s : nếu không muốn mouse nhảy, tức là không muốn sử dụng Undo, vậy chỉ còn cách xóa tập vừa tạo. Lưu ý với matden là cách này trong nhiều trường hợp khá nguy hiểm, nên mình post riêng cho bạn 1 bản như vậy :

(vl-load-com)
(defun c:dar( / dir gr nx p0 px pxv ssFull ss1 vecx ans inc)
(grtext -1 "Dynamic LArray @Ketxu")
(setq m:err *error* *error* err)
(command "undo" "be")
(if (setq ssFull (ST:SS->List-Vla (ssget))
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
 (cond ((ST:Check-Exist '("AcDbText" "AcDbMText") (mapcar 'vla-get-objectname ssFull))  
 (setq ans (strcase(getstring "Copy t\U+0103ng Text ? < K > :")))
  (cond ((not (or (= ans "K")(= ans "")))
(or #num (setq #num 1))
(setq #num (cond ((getint (strcat "\nGia s\U+1ED1 < " (rtos #num 2 0) " > :")))(#num)) inc T)
)
  )
 )
 )
 (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 inc #num))
(grdraw p0 (mapcar '+ p0 pxv) 3 1)
 )
)
)
(command "undo" "en")
(setq ss1 nil)
 (princ)
)
(defun ST:Ss-Copy-Dynamic (sslst n v dir inc num / i matlist obj1 ss transmat xobj isText str isReal)
 (setq ss (ssadd))
 (foreach xobj sslst
(setq i 1)
(cond ((and (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
(cond ((= 'REAL (type (read (setq str (vla-get-textstring xobj)))))
 (setq j (atof str) isReal T))
  (T (setq j (atoi str) isReal nil))
)
(setq isText T)
  )
(T setq isText nil)
)
(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") inc num)
 (vla-put-textstring obj1 (rtos (setq j (+ num j)) 2  (if isReal 1 0))))
  (ssadd (vlax-vla-object->ename obj1) ss)
  (setq i (1+ i))
)
 )
 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 err (msg)  
(if ss1 (ST:Ss-Delete ss1))
(setq *error* m:err
  m:err nil
)
 )

[ketxu 2.984]

Update 1.2 : Cho phép xử lý với cả các Text có format [Tiền tố] số [Hậu tố]

[matden_304 0]

@ketxu

http://www.cadviet.com/upfiles/3/kientruc_2.dwg

Khi rải các text có chứa số thì sao nó bị lỗi font ntn vậy anh

[ketxu 2.984]

Hoàn toàn bình thường, matden ạ. Mình test k có lỗi

[TKTXVD 1]

Vãi hàng quả lisp, gần giống CAD2012 rồi...bác mà làm theo cung tròn nữa thì khỏi phải nói.

[ketxu 2.984]

Vãi hàng quả lisp, gần giống CAD2012 rồi...bác mà làm theo cung tròn nữa thì khỏi phải nói.

Tại sao lại không xúc tiến nhỉ :D

http://www.cadviet.com/forum/index.php?showtopic=54880

[Doan Van Ha 3.191]

Update 1.2 : Cho phép xử lý với cả các Text có format [Tiền tố] số [Hậu tố]

Có 4 điều sau đây (nhỏ thôi) nhưng cũng góp ý để lisp tuyệt vời hơn.

1) "Cot 3.000" => "Cot 4.0" => "Cot 5.0" => đã bàn trong topic khác, nếu Ket không thích thì thôi.

2) "Phong P.1" => "Phong P1.1" =>"Phong P2.1" đáng ra phải "Phong P.1" => "Phong P.2" =>"Phong P.3"

3) "H.A2.3K.E.T.X.U" => nil

Cả 3 điều trên là do (vl-string-search "." num), tức dấu "."

4) Lệnh DAR trùng với 1 lệnh dim của cad.

Thân thương!

P/S: nhân đọc "Polar Array" kiếm được cái hàm "LM:GrText" quá đã, thank.

[ketxu 2.984]

@ĐVH : cám ơn bác đã góp ý, tuy nhiên em không định giải quyết nó trong lisp này. Nếu cần copy text tăng không, đã có rất nhiều lisp khác hoàn thiện hơn chỉ để làm việc này :) (đã ghi chú ).

P/s : Bác thanks về topic bên đó thì vào link đó thôi ạ :D Rất vui vì bác thấy Hay, hi vọng từ đó bác cho ra đời nhiều thứ hay ho hơn

[xuanmyxd 0]

thick nhat la a Ketxu nha ta..Like.ok

[tien2005 241]

@ketxu: Bạn có thể chỉnh lại để lisp có thể thay đổi các text attribute trong block giúp mình được không?

 

Thanks