Đến nội dung


Hình ảnh
- - - - -

[Đã xong] Dynamic LArray


  • Please log in to reply
13 replies to this topic

#1 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 September 2011 - 08:15 PM

@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ố]

Hình đã gửi


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)))
))

  • 9

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#2 matden_304

matden_304

    biết vẽ line

  • Members
  • PipPip
  • 29 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 20 September 2011 - 09:14 PM

Đú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
  • 0

#3 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 September 2011 - 09:41 PM

Đú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é :)
  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#4 matden_304

matden_304

    biết vẽ line

  • Members
  • PipPip
  • 29 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 20 September 2011 - 10:18 PM

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:
  • 0

#5 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 September 2011 - 10:29 PM

@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
)
)

  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#6 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 21 September 2011 - 11:38 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#7 matden_304

matden_304

    biết vẽ line

  • Members
  • PipPip
  • 29 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 22 September 2011 - 03:19 PM

@ketxu
http://www.cadviet.c.../kientruc_2.dwg
Khi rải các text có chứa số thì sao nó bị lỗi font ntn vậy anh
  • 0

#8 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 22 September 2011 - 05:33 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#9 TKTXVD

TKTXVD

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 22 September 2011 - 09:41 PM

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.
  • 0

#10 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 23 September 2011 - 12:21 AM

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.c...showtopic=54880
  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#11 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 23 September 2011 - 03:39 PM

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.
  • 1

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#12 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 23 September 2011 - 07:18 PM

@Đ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
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#13 xuanmyxd

xuanmyxd

    Chưa sử dụng CAD

  • Members
  • Pip
  • 1 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 09 June 2012 - 09:57 PM

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

#14 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 20 June 2012 - 02:38 PM

@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
  • 0