Đến nội dung


Hình ảnh
- - - - -

[Yêu cầu] Lisp cắt đối tượng


  • Please log in to reply
42 replies to this topic

#21 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 11 August 2011 - 07:42 AM

Ồ, bạn dậy sớm vậy ^^
P/s : có lẽ do mình chậm hiểu quá nên hiểu sai ý bạn ^^. Sai 1 li, đi 1 dặm, code lại rối rắm hơn :(

(defun c:brd (/ lst_tmp lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)

;;;;;;;; Local Functions
(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun ST:Ss->ListEnt (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
)
)
(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj "_non" x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq ss_new (ssadd))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (ST:Ss->ListEnt (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (ST:Ss->ListEnt (ssget)))
(foreach obj lst_ss_bicat
(foreach Linedo lst_ss_cat
(ST:Ent-BrkLPSLine obj Linedo)
(setq ss_new (ssadd (entlast) ss_new))
)
(setq lst_tmp (ST:Ss->ListEnt (ssadd obj ss_new)))
(command "erase" (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_tmp))) lst) lst_tmp) "") ;Bo dong nay neu khong muon xoa duong ngan nhat
(setq lst_tmp nil ss_new (ssadd))
;(while (setq EL (entnext EL)) (setq lst_ss_bicat (cons EL lst_ss_bicat)))
;(setq EL (entlast))
)

(command "undo" "end")
)

Còn phần bắt lỗi bắt lủng, nếu bạn làm bình thường thì chắc chẳng cần đâu, chứ bắt hết lỗi thì chắc đến già mất, nên bỏ qua thao tác đó :D. Bạn đợi được nhưng mình thì phải đi công trường bây giờ rồi, hem đợi được. Gluck ^_^

Hình như toàn Ractor hay sao ý. Hii. Trước khi đi công trường vẫn không quên mải mê viết code. Tặng ketxu 1 thanks. Hiii
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#22 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 August 2011 - 08:38 AM

Đoạn collect Ketxu viết vội nên sai, bác nào rảnh giúp giùm bạn Hugo nhé :(
  • 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


#23 hugo007

hugo007

    biết lệnh erase

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

Đã gửi 11 August 2011 - 08:39 AM

Ồ, bạn dậy sớm vậy ^^
P/s : có lẽ do mình chậm hiểu quá nên hiểu sai ý bạn ^^. Sai 1 li, đi 1 dặm, code lại rối rắm hơn :(

Srr code có lỗi

Còn phần bắt lỗi bắt lủng, nếu bạn làm bình thường thì chắc chẳng cần đâu, chứ bắt hết lỗi thì chắc đến già mất, nên bỏ qua thao tác đó :D. Bạn đợi được nhưng mình thì phải đi công trường bây giờ rồi, hem đợi được. Gluck ^_^

Vẫn còn lỗi,1đoạn thẳng chia làm 3 đoạn sao nó lại xoá 2 đoạn ngắn đi vậy bạn?Mình muốn nó xoá đoạn ngắn nhất thôi.Thanks.
  • 0

#24 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 11 August 2011 - 09:02 AM

Ồ, bạn dậy sớm vậy ^^
P/s : có lẽ do mình chậm hiểu quá nên hiểu sai ý bạn ^^. Sai 1 li, đi 1 dặm, code lại rối rắm hơn :(

Srr code có lỗi

Còn phần bắt lỗi bắt lủng, nếu bạn làm bình thường thì chắc chẳng cần đâu, chứ bắt hết lỗi thì chắc đến già mất, nên bỏ qua thao tác đó :D. Bạn đợi được nhưng mình thì phải đi công trường bây giờ rồi, hem đợi được. Gluck ^_^

Vote cho Ketxu vì thông minh + nhiệt tình. Tuy nhiên, chắc do viết vội quá nên tôi check thử thì thấy chưa đúng tuyệt đối. Ket đi CT về gắng "nuốt" luôn nhé, tôi thì "nhai" không nổi mà Ket làm được tới đó thì quá tuyệt vời.
Thân thương!
  • 0

* 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.


#25 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 August 2011 - 09:45 AM

Hề hề, tạm thời bạn Hugo cứ dùng cái code đầu tiên, bỏ dòng command "erase" đi, tự mình xóa tay cũng được ^^ Tối về mình nghiên cứu tiếp xem nó có thông không :) Bây giờ làm vài thứ khác
  • 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


#26 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 11 August 2011 - 10:03 AM

Vẫn còn lỗi,1đoạn thẳng chia làm 3 đoạn sao nó lại xoá 2 đoạn ngắn đi vậy bạn?Mình muốn nó xoá đoạn ngắn nhất thôi.Thanks.

Mình test thử có thấy lỗi thế đâu nhỉ.
Đây là code của ket mình có edit tí chút.

(defun c:brd (/ lst_tmp lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)

(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))

(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj "_non" x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq ss_new (ssadd))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (acet-ss-to-list (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (acet-ss-to-list (ssget)))
(foreach obj lst_ss_bicat
(foreach Linedo lst_ss_cat
(ST:Ent-BrkLPSLine obj Linedo)
(setq ss_new (ssadd (entlast) ss_new))
)
(setq lst_tmp (acet-ss-to-list (ssadd obj ss_new)))
(entdel (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_tmp))) lst) lst_tmp)) ;Bo dong nay neu khong muon xoa duong ngan nhat
(setq lst_tmp nil ss_new (ssadd))
)
(command "undo" "end")
)

  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#27 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 11 August 2011 - 10:14 AM

...chắc do viết vội quá nên tôi check thử thì thấy chưa đúng tuyệt đối...

Vẫn còn lỗi, bác phamngoctukts ạ! Lỗi tôi phát hiện ra là: nó xoá đoạn dài chứ không xoá đoạn ngắn nhất trong 1 đoạn thẳng bị cắt ra (khác lỗi bạn ấy phát hiện).
Thân thương!
  • 0

* 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.


#28 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 11 August 2011 - 10:26 AM

Vẫn còn lỗi, bác phamngoctukts ạ! Lỗi tôi phát hiện ra là: nó xoá đoạn dài chứ không xoá đoạn ngắn nhất trong 1 đoạn thẳng bị cắt ra (khác lỗi bạn ấy phát hiện).
Thân thương!

Bác thử gửi file dwg dùng bị lỗi lên xem. Tôi dùng không thấy lỗi như của Bác nói.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#29 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 11 August 2011 - 10:30 AM

Vậy bạn giúp mình 2 ý sau :Nhờ bạn sửa cho chọn được nhiều line cắt,sau khi cắt xong các đoạn thẳng vừa mới bị cắt ra,đoạn ngắn nhất thì sẽ bị xoá đi được không?Chỉ là Line không phải Polyline.Thanks.

File minh họa đây các bác ah.
http://www.cadviet.c...drawing1_77.dwg

Xin lỗi vì chưa đưa hết ý,n đường cắt,các line cần cắt và line cắt nằm bất kỳ vuông góc hay không vuông góc gì cũng được,các line có thể song song hoặc không song song.Cảm ơn bạn.

Cám ơn bạn hình như bạn có hiểu sai ý mình các đoạn thẳng sau khi chia tại các đường cắt đoạn ngắn nhất trong 1 đoạn thẳng sau khi bị chia sẽ bị xoá chứ không phải ngắn nhất trong tất cả đoạn thẳng sau khi bị chia.Thí dụ mình có 2 đoạn thẳng A và B bị chia bởi 2 đoạn thẳng bất kỳ.đoạn A bị chia làm 3,đoạn B cũng bị chia làm 3.Trong 3 đoạn thằng bị chia bởi đoạn A đoạn nào ngắn nhất sẽ bị xoá tương tự đoạn ngắn nhất trong đoạn B cũng bị xoá.Tóm lại có bao nhiêu đoạn thằng bị cắt bởi đường cắt thì có bấy nhiêu đoạn ngắn nhất bị xoá.Bạn thêm giùm mình phần bẫy lỗi còn thiếu như bạn nói luôn nhe,mình đợi được.Thanks.

Phải tới ít nhất là 4 lần post mới chuyển tải được nội dung ?!
Tiếng Việt mình khó quá nhỉ?!

Bạn sài thử LISP này :
(defun C:brd (/ e i pts ss1 ss2  ss_tmp)
;; By : gia_bach @ www.CadViet.com ;;
(defun Get_pts_ss_inter_ent (ss ent / e i lst_pt obj pts)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old))) new )
(setq i -1 obj (vlax-ename->vla-object ent))
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (vlax-invoke obj 'IntersectWith (vlax-ename->vla-object e) acExtendNone))
(setq lst_pt (append (list->3pair pts) lst_pt)) ))
(vl-sort lst_pt '(lambda (x y) (> (vlax-curve-getParamAtPoint obj x) (vlax-curve-getParamAtPoint obj y)))) )
(defun Get_ent_with_minLen (ss / e i lst)
(setq i -1 )
(while (setq e (ssname ss (setq i (1+ i))))
(setq lst (cons (cons (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) e) lst) ) )
(cdr(car(vl-sort lst '(lambda (x y) (< (car x) (car y)))))) )
;--------------- main -------------------
(vl-load-com)
(if (and (princ "\nChon doi tuong bi cat :")
(setq ss1 (ssget (list (cons 0 "*LINE,ARC"))))
(princ "\nChon doi tuong cat :")
(setq ss2 (ssget (list (cons 0 "*LINE,ARC")))))
(progn
(setq i -1)
(while (setq e (ssname ss1 (setq i (1+ i))))
(setq pts (Get_pts_ss_inter_ent ss2 e))
(setq ss_tmp (ssadd))
(foreach pt pts
(command "._break" e "_non" (trans pt 0 1) "_non" (trans pt 0 1))
(ssadd (entlast) ss_tmp))
(ssadd e ss_tmp)
(entdel (Get_ent_with_minLen ss_tmp)) ) ) )
(princ) )

  • 2

#30 lp_hai

lp_hai

    biết lệnh measure

  • Members
  • PipPipPipPipPipPip
  • 456 Bài viết
Điểm đánh giá: 202 (khá)

Đã gửi 11 August 2011 - 10:35 AM

Bác gia_bach đã giới thiệu lisp cắt đối tượng cho nhiều trường hợp nhưng mình chỉ cần 1 trường hợp khi ta có nhiều đoạn thẳng cắt nhau,khi đánh lệnh lisp,chọn đối tượng cần cắt xong chọn đường thẳng để làm gốc sau đó đường thẳng cần cắt sẽ bị cắt tại vị trí đường thẳng làm gốc.Chân thành cảm ơn.

em viết đoạn code này ko biết có đúng ý bạn hugo ko ah! "chọn đối tượng cần cắt xong chọn đường thẳng để làm gốc" và xóa đi đoạn ngắn hơn.

(defun c:ctt(/ dt sdt ind ob1 ob2 lst1 g a10 a11 d10 d11)
(setq dt (ssget)
sdt (sslength dt)
ind 0
ob2 (vlax-ename->vla-object (car(entsel)))
)
(repeat sdt
(setq ent (ssname dt ind)
ind (1+ ind))
(setq ob1 (vlax-ename->vla-object ent)
lst1 (entget ent)
)
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(setq g (vlax-safearray->list g))
(setq a10 (assoc 10 lst1)
a11 (assoc 11 lst1))
(setq d10 (distance g (list(cadr a10) (caddr a10)) ))
(setq d11 (distance g (list(cadr a11) (caddr a11)) ))
(if (> d10 d11)
(setq lst1(subst (vl-list* 11 g) a11 lst1))
(setq lst1(subst (vl-list* 10 g) a10 lst1))
)
(entmod lst1)
)
)
(princ)

  • 1
Hình đã gửi

#31 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 11 August 2011 - 10:37 AM

Bác thử gửi file dwg dùng bị lỗi lên xem. Tôi dùng không thấy lỗi như của Bác nói.

Đây Bác!
http://www.cadviet.c...drawing1_79.dwg
  • 0

* 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.


#32 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 11 August 2011 - 02:46 PM

Đây Bác!
http://www.cadviet.c...drawing1_79.dwg

Bác thử lại code này xem đã test OK.

(defun c:brd (/ lst_tmp lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)

(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))

(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj "_non" x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss_new (ssadd))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (acet-ss-to-list (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (acet-ss-to-list (ssget)))
(foreach obj lst_ss_bicat
(foreach Linedo lst_ss_cat
(ST:Ent-BrkLPSLine obj Linedo)
(setq ss_new (ssadd (entlast) ss_new))
(ST:Ent-BrkLPSLine (entlast) Linedo)
(setq ss_new (ssadd (entlast) ss_new))
)
(setq lst_tmp (acet-ss-to-list (ssadd obj ss_new)))
(entdel (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_tmp))) lst) lst_tmp)) ;Bo dong nay neu khong muon xoa duong ngan nhat
(setq lst_tmp nil ss_new (ssadd))
)
(setvar "osmode" oldos)
(command "undo" "end")
)

  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#33 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 August 2011 - 02:57 PM

Ôi, cám ơn mọi người đã giúp ket, mới 1 buổi sáng mà đã có bao nhiêu lời giải rồi ^^ Vậy là hok phải bận tâm nữa ^^ Cái vụ del cái em ngắn nhất khù khoằm quá ^^
  • 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


#34 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 11 August 2011 - 03:42 PM

Bác thử lại code này xem đã test OK.


(defun c:brd (/ lst_tmp lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)

(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))

(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj "_non" x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss_new (ssadd))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (acet-ss-to-list (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (acet-ss-to-list (ssget)))
(foreach obj lst_ss_bicat
(foreach Linedo lst_ss_cat
(ST:Ent-BrkLPSLine obj Linedo)
(setq ss_new (ssadd (entlast) ss_new))
(ST:Ent-BrkLPSLine (entlast) Linedo)
(setq ss_new (ssadd (entlast) ss_new))
)
(setq lst_tmp (acet-ss-to-list (ssadd obj ss_new)))
(entdel (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_tmp))) lst) lst_tmp)) ;Bo dong nay neu khong muon xoa duong ngan nhat
(setq lst_tmp nil ss_new (ssadd))
)
(setvar "osmode" oldos)
(command "undo" "end")
)

Bạn thử lại code này xem đã test chưa OK. ^_^
http://www.cadviet.c...awing1_79_2.dwg
  • 0

#35 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 11 August 2011 - 04:17 PM

Bạn thử lại code này xem đã test chưa OK. ^_^
http://www.cadviet.c...awing1_79_2.dwg


Cái thằng 2dPline (100 . AcDb2dPolyline) khó chịu quá Tue_NV ơi ! pótay :excl:
Convert qua Pline thì làm việc bình thường.
  • 0

#36 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 11 August 2011 - 04:28 PM

Cái thằng 2dPline (100 . AcDb2dPolyline) khó chịu quá Tue_NV ơi ! pótay :excl:
Convert qua Pline thì làm việc bình thường.

Code em cũng đã viết xong. Chỉ là chưa xử lý trực tiếp trên 2dPline. Chỉ còn cách convert sang PLINE
Tue_NV xin góp thêm 1 code nữa

(defun get-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun c:brel(/ sschinh sstrim lst_pt lst_ptc ssa i minleng)
;copyright by Tue_NV
(vl-load-com)
(if (and (princ "\nChon doi tuong bi cat :")
(setq sschinh (ssget (list (cons 0 "*LINE,ARC"))))
(princ "\nChon doi tuong cat :")
(setq sstrim (ssget (list (cons 0 "*LINE,ARC")))))
(progn
(Foreach x (acet-ss-to-list sschinh)
(setq lst_pt nil)
(foreach y (acet-ss-to-list sstrim)
(setq lst_pt (append lst_pt (ACET-GEOM-INTERSECTWITH y x 0)))
)
(setq lst_pt (vl-sort lst_pt '(lambda(p1 p2) (> (vlax-curve-getparamatpoint x p1)
(vlax-curve-getparamatpoint x p2)
)
)
)
)
(setq lst_ptc (append lst_ptc (list lst_pt)) )
)
(setq e (entlast) ssa (ssadd) i 0)
(foreach x (acet-ss-to-list sschinh)
(setq ssa (ssadd x ssa))
(foreach y (nth i lst_ptc)
(command "break" x "_non" (trans y 0 1) "_non" (trans y 0 1))
(setq ssa (ssadd (entlast) ssa))
)
(setq minleng (apply 'min (mapcar '(lambda(k) (get-Length k))
(acet-ss-to-list ssa))
)
)
(foreach z (acet-ss-to-list ssa)
(if (= (get-length z) minleng) (entdel z))
)
(setq ssa (ssadd) i (1+ i))

)
)
)
)

  • 2

#37 hugo007

hugo007

    biết lệnh erase

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

Đã gửi 11 August 2011 - 08:36 PM

Cảm ơn các bác rất nhiều.quá nhiều lisp e đang thử xem lisp nào đáp ứng được nhu cầu của e.Hôm nay hết quyền để vote nên mai e sẽ vote tiếp cho các bác.
  • 0

#38 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 11 August 2011 - 09:25 PM

Cảm ơn các bác rất nhiều.quá nhiều lisp e đang thử xem lisp nào đáp ứng được nhu cầu của e.Hôm nay hết quyền để vote nên mai e sẽ vote tiếp cho các bác.

Hề hề hề,
các bác cho mình té nước theo mưa một tí.
Số là mình đọc cái lisp của bác Ketxu và nổi hứng nhảy vô sửa một tí để hy vọng vớ được một phiếu vote của nhà bác Hugo007. Chả biết có nên cơm cháo chi không nhưng cũng liều post nó lên để mọi người ném ...... bánh. Quả này có khi no được mấy ngày ấy chứ. Hề hề hề.
Nó đây ạ:

(defun c:brd (/ EL lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine
n i lst_ss_dacat)

;;;;;;;; Local Functions
(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun ST:Ss->ListEnt (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
)
)
(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq EL (entlast))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (ST:Ss->ListEnt (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (ST:Ss->ListEnt (ssget)))
(foreach obj lst_ss_bicat
(setq lst_ss_dacat (list obj))
(setq n (length lst_ss_cat))
(setq i 0)
(While (< i n)
(setq Linedo (nth i lst_ss_cat))
(foreach obj1 lst_ss_dacat
(ST:Ent-BrkLPSLine obj1 Linedo)
(while (setq EL (entnext EL)) (setq lst_ss_dacat (cons EL lst_ss_dacat)))
(setq EL (entlast))
)
(setq i (1+ i))
)
(command "erase" (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_ss_dacat))) lst) lst_ss_dacat) "")
)
(command "undo" "end")
)


@ Bác Ketxu: Bác viết lisp bằng cai font chi mà dịch nó khổ quá. Giá bác cứ chơi tiếng Việt không dấu thì dễ đọc biết mấy????
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#39 hugo007

hugo007

    biết lệnh erase

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

Đã gửi 11 August 2011 - 10:25 PM

Code em cũng đã viết xong. Chỉ là chưa xử lý trực tiếp trên 2dPline. Chỉ còn cách convert sang PLINE
Tue_NV xin góp thêm 1 code nữa


(defun get-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun c:brel(/ sschinh sstrim lst_pt lst_ptc ssa i minleng)
;copyright by Tue_NV
(vl-load-com)
(if (and (princ "\nChon doi tuong bi cat :")
(setq sschinh (ssget (list (cons 0 "*LINE,ARC"))))
(princ "\nChon doi tuong cat :")
(setq sstrim (ssget (list (cons 0 "*LINE,ARC")))))
(progn
(Foreach x (acet-ss-to-list sschinh)
(setq lst_pt nil)
(foreach y (acet-ss-to-list sstrim)
(setq lst_pt (append lst_pt (ACET-GEOM-INTERSECTWITH y x 0)))
)
(setq lst_pt (vl-sort lst_pt '(lambda(p1 p2) (> (vlax-curve-getparamatpoint x p1)
(vlax-curve-getparamatpoint x p2)
)
)
)
)
(setq lst_ptc (append lst_ptc (list lst_pt)) )
)
(setq e (entlast) ssa (ssadd) i 0)
(foreach x (acet-ss-to-list sschinh)
(setq ssa (ssadd x ssa))
(foreach y (nth i lst_ptc)
(command "break" x "_non" (trans y 0 1) "_non" (trans y 0 1))
(setq ssa (ssadd (entlast) ssa))
)
(setq minleng (apply 'min (mapcar '(lambda(k) (get-Length k))
(acet-ss-to-list ssa))
)
)
(foreach z (acet-ss-to-list ssa)
(if (= (get-length z) minleng) (entdel z))
)
(setq ssa (ssadd) i (1+ i))

)
)
)
)

Cho e hỏi 1 ý nhỏ nữa là tại sao các bác viết code không đưa những dòng yêu cầu lên màn hình ngay vị trí con trỏ chuột,chẳng hạn lisp này dòng CHỌN ĐỐI TƯỢNG BỊ CẮTĐỐI TƯỢNG CẮT lên màn hình để đỡ phải nhìn xuống dòng command.Cảm ơn các bác nhiều.
  • 0

#40 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 11 August 2011 - 10:49 PM

Cho e hỏi 1 ý nhỏ nữa là tại sao các bác viết code không đưa những dòng yêu cầu lên màn hình ngay vị trí con trỏ chuột,chẳng hạn lisp này dòng CHỌN ĐỐI TƯỢNG BỊ CẮTĐỐI TƯỢNG CẮT lên màn hình để đỡ phải nhìn xuống dòng command.Cảm ơn các bác nhiều.

Hề hề hề,
Bạn có thể thay hàm (princ..... ) bằng hàm (alert ....) nó sẽ hiện lên màn hình cho bạn nhòm thoải mái, sau đó nhấn enter để thoát cho khỏi ngứa con mắt....
Hề hề hề....
Mà "nhìn xuống dòng command" cũng là nhìn "lên màn hình" chớ bộ, hề hề hề,.... Hổng nhẽ lại là nhìn sang cô hàng xóm.... hề hề hề
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.