Đến nội dung


Hình ảnh
- - - - -

Lisp xóa toàn bộ đối tượng được ngăn bởi đường thẳng


  • Please log in to reply
47 replies to this topic

#21 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 16 September 2009 - 11:41 PM

Nếu không đổi linetype thì trim được. :s_big:

Cái mình thật sự muốn biết là vì cớ gì mà cad kg thực hiện đc extrim trong trường hợp trên. Nếu trim thì tất nhiên nhưng rất chậm
  • 0

#22 duy782006

duy782006

    PHẠM QUỐC DUY

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

Đã gửi 17 September 2009 - 07:09 AM

Cách của bạn cũng rất hay. Nếu vậy bạn cần lập trình để đặt bộ lisp của bạn trên web sau đó đi đâu cũng có thể xài được. AutoLisp online. :s_big:

Không phải ở đâu cũng có internet đâu bạn. Tụi mình ở nhà quê thì có USB là linh động lắm rồi.
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#23 nataca

nataca

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 712 Bài viết
Điểm đánh giá: 553 (tốt)

Đã gửi 17 September 2009 - 09:10 AM

Cái mình thật sự muốn biết là vì cớ gì mà cad kg thực hiện đc extrim trong trường hợp trên. Nếu trim thì tất nhiên nhưng rất chậm

Bởi vì như sau:
- Thứ nhất đường của bác tạo là 1 linetype không chuẩn của Cad.
- Thứ 2 Lệnh Extrim nó giống như trim với lựa chọn "F" . Nếu đường "fence" không cắt qua đường "chấm chấm" của bác (ở đây là cắt qua đường gạch liền chứ đoạn trống không được coi là cắt) thì nó không tìm thấy giao điểm và không cắt cho bác được. Bác không tin thì thử làm lệnh Trim với lựa chọn "F" xem sao. Điều này cũng xảy ra tương tự với đường Hidden của Cad chứ không riêng gì đường của bác. Sở dĩ lệnh Extrim vẫn cắt được đường Hidden vì : khoảng trống của nó nhỏ hơn so với đường liền, lệnh extrim nó có mấy tầng Fence
  • 0

#24 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 18 September 2009 - 01:22 AM

Bởi vì như sau:
- Thứ nhất đường của bác tạo là 1 linetype không chuẩn của Cad.
- Thứ 2 Lệnh Extrim nó giống như trim với lựa chọn "F" . Nếu đường "fence" không cắt qua đường "chấm chấm" của bác (ở đây là cắt qua đường gạch liền chứ đoạn trống không được coi là cắt) thì nó không tìm thấy giao điểm và không cắt cho bác được. Bác không tin thì thử làm lệnh Trim với lựa chọn "F" xem sao. Điều này cũng xảy ra tương tự với đường Hidden của Cad chứ không riêng gì đường của bác. Sở dĩ lệnh Extrim vẫn cắt được đường Hidden vì : khoảng trống của nó nhỏ hơn so với đường liền, lệnh extrim nó có mấy tầng Fence

Mình biết lệnh select với lựa chọn "f" kg tìm thấy đối tg khi đi qua khoảng trống. Nhưng mình kg hiểu cơ chế chọn của cad là cáí kiểu gì mà kg tìm đc các đg thẳng cắt ngang qua đg "fence". Đôi lúc cad cũng rất "ngớ ngẩn" với một số bài toán khá đơn giản. Với trường hợp trên chỉ cần chọn các đối tg với lựa chọn "c" hoặc "cp", sau đó kiểm tra sự giao nhau của các đối tg với đg "fence" có xét đến bên trong hay ngoài rồi cắt đi là đc. Nếu các bạn làm việc nhiều với các lệnh chọn đối tượng của cad, các bạn sẽ thấy cad còn nhiều "sơ hở", ví dụ việc chọn đối tượng với lựa chọn "cp" đi qua giữa hai đa giác lồng nhau, hay các đối tượng nằm gần đg "fence", cad vẫn chọn nhầm. Hay lệnh tìm đg boundary kg phải lúc nào cũng thành công. Theo mình, lệnh extrim và một số lệnh khác (như boundary...) cần phải đc viết lại. Bác nào đủ bản lĩnh thì ra tay cho anh em mở rộng tầm nhìn (mình kg làm đc)
  • 0

#25 nataca

nataca

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 712 Bài viết
Điểm đánh giá: 553 (tốt)

Đã gửi 18 September 2009 - 08:05 AM

Mình biết lệnh select với lựa chọn "f" kg tìm thấy đối tg khi đi qua khoảng trống. Nhưng mình kg hiểu cơ chế chọn của cad là cáí kiểu gì mà kg tìm đc các đg thẳng cắt ngang qua đg "fence". Đôi lúc cad cũng rất "ngớ ngẩn" với một số bài toán khá đơn giản. Với trường hợp trên chỉ cần chọn các đối tg với lựa chọn "c" hoặc "cp", sau đó kiểm tra sự giao nhau của các đối tg với đg "fence" có xét đến bên trong hay ngoài rồi cắt đi là đc. Nếu các bạn làm việc nhiều với các lệnh chọn đối tượng của cad, các bạn sẽ thấy cad còn nhiều "sơ hở", ví dụ việc chọn đối tượng với lựa chọn "cp" đi qua giữa hai đa giác lồng nhau, hay các đối tượng nằm gần đg "fence", cad vẫn chọn nhầm. Hay lệnh tìm đg boundary kg phải lúc nào cũng thành công. Theo mình, lệnh extrim và một số lệnh khác (như boundary...) cần phải đc viết lại. Bác nào đủ bản lĩnh thì ra tay cho anh em mở rộng tầm nhìn (mình kg làm đc)

Theo em thì không nên viết lại. Mình chỉ thay đổi, thêm thắt một chút trong lisp express là có thể khắc phục được lỗi gây ra
Ví dụ:
(defun C:EXX ()
(setq ss (ssget "X"))
(vl-cmdf "CHPROP" ss "" "LT" "Continuous" "")
(C:EXTRIM)
(vl-cmdf "CHPROP" ss "" "LT" "bylayer" "")
)

Đảm bảo là lệnh EXX luôn cắt được. Việc Bylayer chỉ là một ví dụ. Mình có thể lưu lại kiểu đường nét rồi gán lại sau. Đây là một cách để chữa cháy
  • 0

#26 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 18 September 2009 - 08:39 AM

Theo em thì không nên viết lại. Mình chỉ thay đổi, thêm thắt một chút trong lisp express là có thể khắc phục được lỗi gây ra
Ví dụ:

(defun C:EXX ()
(setq ss (ssget "X"))
(vl-cmdf "CHPROP" ss "" "LT" "Continuous" "")
(C:EXTRIM)
(vl-cmdf "CHPROP" ss "" "LT" "bylayer" "")
)

Đảm bảo là lệnh EXX luôn cắt được. Việc Bylayer chỉ là một ví dụ. Mình có thể lưu lại kiểu đường nét rồi gán lại sau. Đây là một cách để chữa cháy

Mục đích là đạt đc mục đích, cách nào càng ngắn gọn càng tốt. Cách của bạn cũng đc, nhưng nếu đối tượng có linetype kg phải là bylayer thì sẽ làm sai tính chất của nó. Việc lưu lại đg nét chỉ đúng khi đối tượng kg thay đổi ename, nếu đg tg bị cắt thành nhiều đọan thì sẽ sinh ra dt mới do đó mình kg thể theo dõi đc
  • 0

#27 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 18 September 2009 - 09:15 AM

Mình biết lệnh select với lựa chọn "f" kg tìm thấy đối tg khi đi qua khoảng trống. Nhưng mình kg hiểu cơ chế chọn của cad là cáí kiểu gì mà kg tìm đc các đg thẳng cắt ngang qua đg "fence". Đôi lúc cad cũng rất "ngớ ngẩn" với một số bài toán khá đơn giản. Với trường hợp trên chỉ cần chọn các đối tg với lựa chọn "c" hoặc "cp", sau đó kiểm tra sự giao nhau của các đối tg với đg "fence" có xét đến bên trong hay ngoài rồi cắt đi là đc. Nếu các bạn làm việc nhiều với các lệnh chọn đối tượng của cad, các bạn sẽ thấy cad còn nhiều "sơ hở", ví dụ việc chọn đối tượng với lựa chọn "cp" đi qua giữa hai đa giác lồng nhau, hay các đối tượng nằm gần đg "fence", cad vẫn chọn nhầm. Hay lệnh tìm đg boundary kg phải lúc nào cũng thành công. Theo mình, lệnh extrim và một số lệnh khác (như boundary...) cần phải đc viết lại. Bác nào đủ bản lĩnh thì ra tay cho anh em mở rộng tầm nhìn (mình kg làm đc)

Thiep đồng quan điểm với TRUNGNGAMY, lệnh extrim vẫn chưa hoàn thiện, cụ thể khi cắt 1 bản đồ có nhiều đường contour thì nó cắt không gọn gàng, không hết. Sau khi cắt xong, nếu không cẩn thận, xóa các đối tượng ngoài (hoặc trong) bằng kiểu chọn window sát mép đường bao chắn thì sẽ xóa luôn các đường contour chưa bị cắt.
  • 0

#28 nataca

nataca

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 712 Bài viết
Điểm đánh giá: 553 (tốt)

Đã gửi 18 September 2009 - 09:19 AM

Mục đích là đạt đc mục đích, cách nào càng ngắn gọn càng tốt. Cách của bạn cũng đc, nhưng nếu đối tượng có linetype kg phải là bylayer thì sẽ làm sai tính chất của nó. Việc lưu lại đg nét chỉ đúng khi đối tượng kg thay đổi ename, nếu đg tg bị cắt thành nhiều đọan thì sẽ sinh ra dt mới do đó mình kg thể theo dõi đc

Ename của đối tượng không bị đổi trước và sau khi "trim" bác ạ :s_big:
  • 0

#29 nataca

nataca

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 712 Bài viết
Điểm đánh giá: 553 (tốt)

Đã gửi 18 September 2009 - 09:40 AM

Thiep đồng quan điểm với TRUNGNGAMY, lệnh extrim vẫn chưa hoàn thiện, cụ thể khi cắt 1 bản đồ có nhiều đường contour thì nó cắt không gọn gàng, không hết. Sau khi cắt xong, nếu không cẩn thận, xóa các đối tượng ngoài (hoặc trong) bằng kiểu chọn window sát mép đường bao chắn thì sẽ xóa luôn các đường contour chưa bị cắt.

Lệnh Extrim hoạt động dựa trên nguyên tắc "fence" với đường Fence chính là đối tượng làm dao cắt được offset với khoảng cách là
(* (getvar "viewsize") 0.05). Như vậy nó phụ thuộc vào độ zoom của màn hình. Thực tế với tất cả các lisp nào cũng thế thôi. Càng zoom cho đối tượng nhỏ đi thì độ chính xác đều bị giảm. Ngay cả với lệnh select cũng thế. Khi Extrim thì nó zoom "e" màn hình để trim được tất cả các đối tượng cùng 1 lúc. Đối tượng càng bị zoom nhỏ đi thì sự tìm giao điểm để cắt càng thiếu chính xác. Có một cách để thay đổi thuật toán đi là Trim cho từng đối tượng lần lượt. Đến đối tượng nào thì chỉ zoom "E" đối tượng đó . Tuy nhiên với bản vẽ có quá nhiều đối tượng thì việc Zoom nó làm chậm tốc độ chương trình và màn hình cũng nhẩy loạn lên.
  • 0

#30 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 18 September 2009 - 10:04 AM

Mình nhờ các bạn giúp thực hiện lệnh extrim cho file đơn giản sau nhưng kg đc thay đổi tính chất các đối tg
Hình đã gửi
file cad http://www.cadviet.c.../dungextrim.dwg

Bạn thử đặt biến hệ thống LtScale (global linetype scale factor) về 1 giá trị đủ nhỏ vd: 0.0001
Khi đó các nét đứt sẽ thành liên tục.
(defun c:test (/ vl ov)
(command "undo" "be")
(setq vl '("osmode" "orthomode" "cmdecho" "LtScale") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0 0.0001))
;gọi lệnh Extrim
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "undo" "e")(princ)
)


To : nataca

Ename của đối tượng không bị đổi trước và sau khi "trim" bác ạ

Đúng là : Ename của đối tượng không bị đổi trước và sau khi "trim" ,
nhưng với truờng hợp đối tuợng sau khi Trim đuợc chia thành 2 đối tuợng.
Việc quản lý Ename của đối tuợng mới tạo ra như thế nào?
  • 0

#31 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 19 September 2009 - 01:25 AM

Cách này hay àh. Thoả mãn yêu cầu không thay đổi thuộc tính đối tượng mà vẫn trim được. :cheers:

Cũng kg đc. Mình đã đặt biến hệ thống LtScale nhỏ đến 0.000001 cũng vậy.
  • 0

#32 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 21 September 2009 - 03:34 PM

Em có được đọc topic về lisp xóa toàn bộ đối tượng trong vùng khép kín ở đây: http://www.cadviet.c...showtopic=11747 Em muốn thay đổi lisp để có thể xóa toàn bộ các đối tượng nằm về 1 phía của 1 đường thẳng như trong ví dụ này http://www.cadviet.c...les/2/vi_du.dwg. Nhờ bác Thiep và bác Gia_bach và các bác am hiểu về lisp sửa giúp nhé :cheers:

Chào hai_1401, sao hai_1401 đưa 1 bản vẽ ví dụ là 3d? Các đường màu đỏ toàn là 3DPOLYLINE, tạo với nhau như là 1 khung cửi nhốt các text lại!!
Bản vẽ này làm mình mất rất nhiều thời gian test lisp. Lisp Thiep viết cứ báo lỗi mãi! Ái chà, đây cũng là 1 bài học cho Thiep đây.
  • 1

#33 hai_1401

hai_1401

    biết lệnh rotate

  • Members
  • PipPipPip
  • 134 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 21 September 2009 - 09:35 PM

Chào hai_1401, sao hai_1401 đưa 1 bản vẽ ví dụ là 3d? Các đường màu đỏ toàn là 3DPOLYLINE, tạo với nhau như là 1 khung cửi nhốt các text lại!!
Bản vẽ này làm mình mất rất nhiều thời gian test lisp. Lisp Thiep viết cứ báo lỗi mãi! Ái chà, đây cũng là 1 bài học cho Thiep đây.

Em thành thật xin lỗi bác Thiep. Chẳng qua là hôm ấy ở cơ quan và cái máy em ngồi ko phải là máy của em nên em đành chọn đại 1 cái bản vẽ bất kỳ trên màn hình Desktop làm ví dụ, em cũng chẳng để ý là 2D hay 3D j j đó đâu, mong bác thông cảm. Trước hết cứ thanks bác vì nhiệt tình cái đã :cheers:
  • 0

#34 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 28 September 2009 - 10:17 AM

Em có được đọc topic về lisp xóa toàn bộ đối tượng trong vùng khép kín ở đây: http://www.cadviet.c...showtopic=11747 Em muốn thay đổi lisp để có thể xóa toàn bộ các đối tượng nằm về 1 phía của 1 đường thẳng như trong ví dụ này http://www.cadviet.c...les/2/vi_du.dwg. Nhờ bác Thiep và bác Gia_bach và các bác am hiểu về lisp sửa giúp nhé :cheers:

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng chặn
;; ERCLINE.LSP free lisp from cadviet.com
;; copyright by Thiep,09/2009
;;;--------------------------
(defun line (Model p1 p2)
(vla-Addline
Model
(vlax-3d-point p1)
(vlax-3d-point p2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
(setq v (mapcar '- Pt1 Pt2)
w (mapcar '- Pt3 Pt2))
(- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;;-----------------------
(defun SS-enlst (ss / c L)
(setq c -1)
(repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
)
(reverse L)
)
;;;-----------------------MAIN LISP----------------------------
(vl-load-com)
(defun c:er2l (/ encur enobjL objL objLW1 tmp LenssBR
ss1 ss2 regn ll ur ul lr
oc1 oc2 oc3 oc4 c1 c2 c3
c4 ps pe p2 enXL enc1 enc2
enc3 enc4 ssER LenssER
)
(princ "\nFree lisp from www.cadviet.com")

(acet-error-init
(list
(list "cmdecho" 0 "highlight" 0 "regenmode"
1 "osmode" 0 "ucsicon" 0
"offsetdist" 0 "attreq" 0
"plinewid" 0 "plinetype" 1 "gridmode"
0 "celtype" "CONTINUOUS" "ucsfollow"
0 "limcheck" 0
)
T

;;;flag. True means use undo for error clean up.
'
(if
redraw_it
(redraw na 4)
)
)
)
;;;acet-error-init
;;;--------------------
(command "undo" "be")
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setvar "osmode" 0)
(setvar "pdmode" 0)
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if
(and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq encur (ssname (ssget '((0 . "LINE"))) 0))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching encur))
)
(break_with ss1 encur)
)
;;;======================================
(redraw encur 3)
(setq objL (vlax-ename->vla-object encur)
ps (vlax-curve-getstartpoint objL)
pe (vlax-curve-getendpoint objL)
Xs (car ps)
Ys (cadr ps)
Xe (car pe)
Ye (cadr pe)
)
(setq p2 (getpoint "pick a point side:"))
(setq ll (getvar "extmin")
ur (getvar "extmax")
lr (list (car ur) (cadr ll) 0.0)
ul (list (car ll) (cadr ur) 0.0)
ll (list (car ll) (cadr ll) 0.0)
ur (list (car ur) (cadr ur) 0.0)
)
(setq regn (CalcZ ps p2 pe))
(if (< regn 0)
(setq flag -0.1)
(setq flag 0.1)
)
(setq objLW1 (car (vlax-safearray->list
(vlax-variant-value (vla-offset objL flag))
)
)
enobjL (vlax-vla-object->ename objLW1)
)
(setq LenssBR (gettouching enobjL))
(mapcar 'entdel LenssBR)
;;;-------------------------
(vla-put-visible objL :vlax-false)
(setq enc1 (vlax-vla-object->ename (line *Model* ll ul))
enc2 (vlax-vla-object->ename (line *Model* ul ur))
enc3 (vlax-vla-object->ename (line *Model* ur lr))
enc4 (vlax-vla-object->ename (line *Model* lr ll))
c1 (car (acet-geom-intersectwith enc1 enobjL 2))
c2 (car (acet-geom-intersectwith enc2 enobjL 2))
c3 (car (acet-geom-intersectwith enc3 enobjL 2))
c4 (car (acet-geom-intersectwith enc4 enobjL 2))
)
(mapcar 'entdel
(list enobjL enc1 enc2 enc3 enc4)
)
(cond ((and c1 c2 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 ur lr ll c1))
(setq lstfen (list c1 ul c2))
)
)
((and c1 c2 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul c2))
(setq lstfen (list c2 ur lr ll c1))
)
)
((and c1 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 lr ll))
(setq lstfen (list c1 c3 ur ul))
)
)
((and c1 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 ur ul))
(setq lstfen (list c1 c3 lr ll))
)
)
((and c1 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c4 ll))
(setq lstfen (list c1 ul ur lr c4))
)
)
((and c1 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul ur lr c4))
(setq lstfen (list c1 c4 ll))
)
)
((and c2 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 lr ll ul))
(setq lstfen (list c2 c3 ur))
)
)
((and c2 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 ur))
(setq lstfen (list c2 c3 lr ll ul))
)
)
((and c2 c4 (< Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 ur lr c4))
(setq lstfen (list c2 c4 ll ul))
)
)
((and c2 c4 (> Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 c4 ll ul))
(setq lstfen (list c2 ur lr c4))
)
)
((and c3 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c3 lr c4))
(setq lstfen (list c4 ll ul ur c3))
)
)
((and c3 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c4 ll ul ur c3))
(setq lstfen (list c3 lr c4))
)
)
); end cond
(setq ssER (ssget "CP" lstfen))
(if ssER
(progn
(setq LenssER (SS-enlst ssER))
(if (member encur LenssER)
(setq LenssER (SS-enlst (ssdel encur ssER)))
)
(vla-put-visible objL :vlax-false)
(mapcar 'entdel LenssER)
)
)
(vla-put-visible objL :vlax-true)
(vlax-invoke-method ActDoc 'Regen acActiveViewport) ; regen
(command "undo" "end")
(acet-error-restore)
(setvar "pdmode" 35)
(princ)
(princ
"\nChuc cac ban may man va thanh cong - Thiep 0918841230"
)
(princ)
)
;;;====================================================================
(defun break_with (ss2brk enL / lst masterlist ss oc break_obj intpts)
(princ "\nCalculating Break Points, Please Wait.\n")

;;========================================
;; Break entity at break points in list
;;========================================

(defun break_obj (ent brkptlst / brkobjlst en
enttype maxparam closedobj minparam
obj obj2break p1param p2param
brkpt2 dlst idx brkptS
brkptE brkpt result result
ignore dist tmppt #ofpts
enddist lastent obj2break stdist
)
(setq obj2break ent
brkobjlst (list ent)
enttype (dxf 0 ent)
closedobj (vlax-curve-isclosed obj2break)
)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst
(mapcar
'(lambda (x)
(list
x
(vlax-curve-getdistatparam
obj2break
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint obj2break x)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
x
)
)
)
)
)
)
)
brkptlst
)
)
;; sort primary list on distance
(setq
brkptlst (vl-sort brkptlst
'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
)
)

;; -----------------------------------------------------

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(setq brkptS (car brkpt)
brkptE brkptS
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break tmppt)
)
)
)
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while
(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj tmppt)
)
)
(null (setq obj2break obj))
; switch objects, null causes exit
t
)
)
)
)
)
)
); end (if brkobjlst

;;; Handle any objects that can not be used with the Break Command
;;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
;;; single breakpoint ----------------------------------------------------
(if
(and closedobj
(not (setq
brkptE (vlax-curve-getPointAtDist
obj2break
(+ (vlax-curve-getdistatparam
obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
)
)
)
(setq
brkptE (vlax-curve-getPointAtDist
obj2break
(- (vlax-curve-getdistatparam
obj2break
(cond ((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
); end setq brkptE
); end fi (and closedobj

(setq LastEnt (GetLastEnt))
(command "._break"
obj2break
"_non"
(trans brkptS 0 1)
"_non"
(trans brkptE 0 1)
)
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast)))
)
(setq brkobjlst (cons (entlast) brkobjlst))
); end (if (and
); end (foreach brkpt (reverse brkptlst)
);end progn brkptlst
); end if brkptlst

); defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt (/ ename result)
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(if (and ss2brk enL)
(progn
(setq oc 0)
;; CREATE a list of entity & it's break points
(foreach en (SS-enlst ss2brk)
; check each object in ss2brk
(if (not (acet-layer-locked (dxf 8 en)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(if (and (not (equal en enint))
(setq intpts (acet-geom-intersectwith en enL 0))
)
(setq lst (append intpts lst))
; entity w/ break points
)
(princ (strcat "Objects Checked: "
(itoa (setq oc (1+ oc)))
"\r"
)
)
(if lst
(setq masterlist
(cons (cons en lst) masterlist)
)
)
)
)
)
(princ "\nBreaking Objects.\n")
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
(and
(setq objl (vlax-ename->vla-object en))
(setq
ss
(ssget
"_A"
(list
(cons 0
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
)
)
)
(setq lst (SS-enlst ss)
lst (mapcar 'vlax-ename->vla-object lst)
)
(mapcar
'(lambda (x)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith objl x acextendnone)
)
)
)
)
)
)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
)
lst
)
)
lstc
)

  • 6

#35 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 28 September 2009 - 06:53 PM

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng chặn

Cám ơn! Cám ơn! Lisp chạy rất chuẩn, kể cả các đối tg phức tạp. Quả là bạn làm đc điều mình kg ngờ. Thừa thắng xông lên, bạn viết lại quách cái lệnh extrim cho rồi. Bạn thử khi cho đg giới hạn là các loại đối tg khác line như polyline, arc, spline ... xem sao
Hình như lisp chạy kg chuẩn lắm khi zoom to lên. Tức là khi có một số đối tg nằm ngoài màn hình
  • 0

#36 hai_1401

hai_1401

    biết lệnh rotate

  • Members
  • PipPipPip
  • 134 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 28 September 2009 - 10:27 PM

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng chặn

;; ERCLINE.LSP free lisp from cadviet.com
;; copyright by Thiep,09/2009
;;;--------------------------
(defun line (Model p1 p2)
(vla-Addline
Model
(vlax-3d-point p1)
(vlax-3d-point p2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
(setq v (mapcar '- Pt1 Pt2)
w (mapcar '- Pt3 Pt2))
(- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;;-----------------------
(defun SS-enlst (ss / c L)
(setq c -1)
(repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
)
(reverse L)
)
;;;-----------------------MAIN LISP----------------------------
(vl-load-com)
(defun c:er2l (/ encur enobjL objL objLW1 tmp LenssBR
ss1 ss2 regn ll ur ul lr
oc1 oc2 oc3 oc4 c1 c2 c3
c4 ps pe p2 enXL enc1 enc2
enc3 enc4 ssER LenssER
)
(princ "\nFree lisp from www.cadviet.com")

(acet-error-init
(list
(list "cmdecho" 0 "highlight" 0 "regenmode"
1 "osmode" 0 "ucsicon" 0
"offsetdist" 0 "attreq" 0
"plinewid" 0 "plinetype" 1 "gridmode"
0 "celtype" "CONTINUOUS" "ucsfollow"
0 "limcheck" 0
)
T

;;;flag. True means use undo for error clean up.
'
(if
redraw_it
(redraw na 4)
)
)
)
;;;acet-error-init
;;;--------------------
(command "undo" "be")
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setvar "osmode" 0)
(setvar "pdmode" 0)
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if
(and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq encur (ssname (ssget '((0 . "LINE"))) 0))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching encur))
)
(break_with ss1 encur)
)
;;;======================================
(redraw encur 3)
(setq objL (vlax-ename->vla-object encur)
ps (vlax-curve-getstartpoint objL)
pe (vlax-curve-getendpoint objL)
Xs (car ps)
Ys (cadr ps)
Xe (car pe)
Ye (cadr pe)
)
(setq p2 (getpoint "pick a point side:"))
(setq ll (getvar "extmin")
ur (getvar "extmax")
lr (list (car ur) (cadr ll) 0.0)
ul (list (car ll) (cadr ur) 0.0)
ll (list (car ll) (cadr ll) 0.0)
ur (list (car ur) (cadr ur) 0.0)
)
(setq regn (CalcZ ps p2 pe))
(if (< regn 0)
(setq flag -0.1)
(setq flag 0.1)
)
(setq objLW1 (car (vlax-safearray->list
(vlax-variant-value (vla-offset objL flag))
)
)
enobjL (vlax-vla-object->ename objLW1)
)
(setq LenssBR (gettouching enobjL))
(mapcar 'entdel LenssBR)
;;;-------------------------
(vla-put-visible objL :vlax-false)
(setq enc1 (vlax-vla-object->ename (line *Model* ll ul))
enc2 (vlax-vla-object->ename (line *Model* ul ur))
enc3 (vlax-vla-object->ename (line *Model* ur lr))
enc4 (vlax-vla-object->ename (line *Model* lr ll))
c1 (car (acet-geom-intersectwith enc1 enobjL 2))
c2 (car (acet-geom-intersectwith enc2 enobjL 2))
c3 (car (acet-geom-intersectwith enc3 enobjL 2))
c4 (car (acet-geom-intersectwith enc4 enobjL 2))
)
(mapcar 'entdel
(list enobjL enc1 enc2 enc3 enc4)
)
(cond ((and c1 c2 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 ur lr ll c1))
(setq lstfen (list c1 ul c2))
)
)
((and c1 c2 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul c2))
(setq lstfen (list c2 ur lr ll c1))
)
)
((and c1 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 lr ll))
(setq lstfen (list c1 c3 ur ul))
)
)
((and c1 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 ur ul))
(setq lstfen (list c1 c3 lr ll))
)
)
((and c1 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c4 ll))
(setq lstfen (list c1 ul ur lr c4))
)
)
((and c1 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul ur lr c4))
(setq lstfen (list c1 c4 ll))
)
)
((and c2 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 lr ll ul))
(setq lstfen (list c2 c3 ur))
)
)
((and c2 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 ur))
(setq lstfen (list c2 c3 lr ll ul))
)
)
((and c2 c4 (< Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 ur lr c4))
(setq lstfen (list c2 c4 ll ul))
)
)
((and c2 c4 (> Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 c4 ll ul))
(setq lstfen (list c2 ur lr c4))
)
)
((and c3 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c3 lr c4))
(setq lstfen (list c4 ll ul ur c3))
)
)
((and c3 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c4 ll ul ur c3))
(setq lstfen (list c3 lr c4))
)
)
); end cond
(setq ssER (ssget "CP" lstfen))
(if ssER
(progn
(setq LenssER (SS-enlst ssER))
(if (member encur LenssER)
(setq LenssER (SS-enlst (ssdel encur ssER)))
)
(vla-put-visible objL :vlax-false)
(mapcar 'entdel LenssER)
)
)
(vla-put-visible objL :vlax-true)
(vlax-invoke-method ActDoc 'Regen acActiveViewport) ; regen
(command "undo" "end")
(acet-error-restore)
(setvar "pdmode" 35)
(princ)
(princ
"\nChuc cac ban may man va thanh cong - Thiep 0918841230"
)
(princ)
)
;;;====================================================================
(defun break_with (ss2brk enL / lst masterlist ss oc break_obj intpts)
(princ "\nCalculating Break Points, Please Wait.\n")

;;========================================
;; Break entity at break points in list
;;========================================

(defun break_obj (ent brkptlst / brkobjlst en
enttype maxparam closedobj minparam
obj obj2break p1param p2param
brkpt2 dlst idx brkptS
brkptE brkpt result result
ignore dist tmppt #ofpts
enddist lastent obj2break stdist
)
(setq obj2break ent
brkobjlst (list ent)
enttype (dxf 0 ent)
closedobj (vlax-curve-isclosed obj2break)
)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst
(mapcar
'(lambda (x)
(list
x
(vlax-curve-getdistatparam
obj2break
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint obj2break x)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
x
)
)
)
)
)
)
)
brkptlst
)
)
;; sort primary list on distance
(setq
brkptlst (vl-sort brkptlst
'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
)
)

;; -----------------------------------------------------

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(setq brkptS (car brkpt)
brkptE brkptS
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break tmppt)
)
)
)
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while
(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj tmppt)
)
)
(null (setq obj2break obj))
; switch objects, null causes exit
t
)
)
)
)
)
)
); end (if brkobjlst

;;; Handle any objects that can not be used with the Break Command
;;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
;;; single breakpoint ----------------------------------------------------
(if
(and closedobj
(not (setq
brkptE (vlax-curve-getPointAtDist
obj2break
(+ (vlax-curve-getdistatparam
obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
)
)
)
(setq
brkptE (vlax-curve-getPointAtDist
obj2break
(- (vlax-curve-getdistatparam
obj2break
(cond ((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
); end setq brkptE
); end fi (and closedobj

(setq LastEnt (GetLastEnt))
(command "._break"
obj2break
"_non"
(trans brkptS 0 1)
"_non"
(trans brkptE 0 1)
)
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast)))
)
(setq brkobjlst (cons (entlast) brkobjlst))
); end (if (and
); end (foreach brkpt (reverse brkptlst)
);end progn brkptlst
); end if brkptlst

); defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt (/ ename result)
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(if (and ss2brk enL)
(progn
(setq oc 0)
;; CREATE a list of entity & it's break points
(foreach en (SS-enlst ss2brk)
; check each object in ss2brk
(if (not (acet-layer-locked (dxf 8 en)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(if (and (not (equal en enint))
(setq intpts (acet-geom-intersectwith en enL 0))
)
(setq lst (append intpts lst))
; entity w/ break points
)
(princ (strcat "Objects Checked: "
(itoa (setq oc (1+ oc)))
"\r"
)
)
(if lst
(setq masterlist
(cons (cons en lst) masterlist)
)
)
)
)
)
(princ "\nBreaking Objects.\n")
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
(and
(setq objl (vlax-ename->vla-object en))
(setq
ss
(ssget
"_A"
(list
(cons 0
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
)
)
)
(setq lst (SS-enlst ss)
lst (mapcar 'vlax-ename->vla-object lst)
)
(mapcar
'(lambda (x)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith objl x acextendnone)
)
)
)
)
)
)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
)
lst
)
)
lstc
)

Cám ơn bác rất nhiều, lisp bác viết rất đúng ý em và chạy cũng rất chuẩn, thanks :cheers:
  • 1

#37 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 29 September 2009 - 10:35 AM

Cám ơn! Cám ơn! Lisp chạy rất chuẩn, kể cả các đối tg phức tạp. Quả là bạn làm đc điều mình kg ngờ. Thừa thắng xông lên, bạn viết lại quách cái lệnh extrim cho rồi. Bạn thử khi cho đg giới hạn là các loại đối tg khác line như polyline, arc, spline ... xem sao
Hình như lisp chạy kg chuẩn lắm khi zoom to lên. Tức là khi có một số đối tg nằm ngoài màn hình

Cám ơn TRUNGNGAMY có lời động viên, Thiep cũng muốn nâng cấp lisp ERL thay cho lệnh EXTRIM nhưng vẫn còn nhiều vấn đề về thuật toán mình chưa giải quyết được: miền cần xóa, Thiep sẽ cố gắng.
Còn lisp chạy không đúng khi zoom to lên, ngay cả lệnh gốc của Autocad, lệnh nào khi yêu cầu chọn đối tượng trên màn hình, người dùng chọn xong các đối tượng trên màn hình, sau đó kéo rê màn hình để chọn các đối tượng khác thì các đối tượng vừa chọn xong nếu nằm ngoài màn hình sẽ có cái không còn nằm trong tập hợp chọn nữa. Vì vậy để cho các lệnh Autocad chạy chuẩn thì người dùng phải zoom E trước.
Thiep sẽ bổ sung zoom E vào lisp ERL
  • 1

#38 study_forever

study_forever

    biết vẽ line

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

Đã gửi 14 October 2009 - 12:23 PM

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng chặn

;; ERCLINE.LSP free lisp from cadviet.com
;; copyright by Thiep,09/2009
;;;--------------------------
(defun line (Model p1 p2)
(vla-Addline
Model
(vlax-3d-point p1)
(vlax-3d-point p2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
(setq v (mapcar '- Pt1 Pt2)
w (mapcar '- Pt3 Pt2))
(- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;;-----------------------
(defun SS-enlst (ss / c L)
(setq c -1)
(repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
)
(reverse L)
)
;;;-----------------------MAIN LISP----------------------------
(vl-load-com)
(defun c:er2l (/ encur enobjL objL objLW1 tmp LenssBR
ss1 ss2 regn ll ur ul lr
oc1 oc2 oc3 oc4 c1 c2 c3
c4 ps pe p2 enXL enc1 enc2
enc3 enc4 ssER LenssER
)
(princ "\nFree lisp from www.cadviet.com")

(acet-error-init
(list
(list "cmdecho" 0 "highlight" 0 "regenmode"
1 "osmode" 0 "ucsicon" 0
"offsetdist" 0 "attreq" 0
"plinewid" 0 "plinetype" 1 "gridmode"
0 "celtype" "CONTINUOUS" "ucsfollow"
0 "limcheck" 0
)
T

;;;flag. True means use undo for error clean up.
'
(if
redraw_it
(redraw na 4)
)
)
)
;;;acet-error-init
;;;--------------------
(command "undo" "be")
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setvar "osmode" 0)
(setvar "pdmode" 0)
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if
(and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq encur (ssname (ssget '((0 . "LINE"))) 0))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching encur))
)
(break_with ss1 encur)
)
;;;======================================
(redraw encur 3)
(setq objL (vlax-ename->vla-object encur)
ps (vlax-curve-getstartpoint objL)
pe (vlax-curve-getendpoint objL)
Xs (car ps)
Ys (cadr ps)
Xe (car pe)
Ye (cadr pe)
)
(setq p2 (getpoint "pick a point side:"))
(setq ll (getvar "extmin")
ur (getvar "extmax")
lr (list (car ur) (cadr ll) 0.0)
ul (list (car ll) (cadr ur) 0.0)
ll (list (car ll) (cadr ll) 0.0)
ur (list (car ur) (cadr ur) 0.0)
)
(setq regn (CalcZ ps p2 pe))
(if (< regn 0)
(setq flag -0.1)
(setq flag 0.1)
)
(setq objLW1 (car (vlax-safearray->list
(vlax-variant-value (vla-offset objL flag))
)
)
enobjL (vlax-vla-object->ename objLW1)
)
(setq LenssBR (gettouching enobjL))
(mapcar 'entdel LenssBR)
;;;-------------------------
(vla-put-visible objL :vlax-false)
(setq enc1 (vlax-vla-object->ename (line *Model* ll ul))
enc2 (vlax-vla-object->ename (line *Model* ul ur))
enc3 (vlax-vla-object->ename (line *Model* ur lr))
enc4 (vlax-vla-object->ename (line *Model* lr ll))
c1 (car (acet-geom-intersectwith enc1 enobjL 2))
c2 (car (acet-geom-intersectwith enc2 enobjL 2))
c3 (car (acet-geom-intersectwith enc3 enobjL 2))
c4 (car (acet-geom-intersectwith enc4 enobjL 2))
)
(mapcar 'entdel
(list enobjL enc1 enc2 enc3 enc4)
)
(cond ((and c1 c2 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 ur lr ll c1))
(setq lstfen (list c1 ul c2))
)
)
((and c1 c2 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul c2))
(setq lstfen (list c2 ur lr ll c1))
)
)
((and c1 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 lr ll))
(setq lstfen (list c1 c3 ur ul))
)
)
((and c1 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c3 ur ul))
(setq lstfen (list c1 c3 lr ll))
)
)
((and c1 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 c4 ll))
(setq lstfen (list c1 ul ur lr c4))
)
)
((and c1 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c1 ul ur lr c4))
(setq lstfen (list c1 c4 ll))
)
)
((and c2 c3 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 lr ll ul))
(setq lstfen (list c2 c3 ur))
)
)
((and c2 c3 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c2 c3 ur))
(setq lstfen (list c2 c3 lr ll ul))
)
)
((and c2 c4 (< Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 ur lr c4))
(setq lstfen (list c2 c4 ll ul))
)
)
((and c2 c4 (> Ys Ye))
(if (< regn 0)
(setq lstfen (list c2 c4 ll ul))
(setq lstfen (list c2 ur lr c4))
)
)
((and c3 c4 (< Xs Xe))
(if (< regn 0)
(setq lstfen (list c3 lr c4))
(setq lstfen (list c4 ll ul ur c3))
)
)
((and c3 c4 (> Xs Xe))
(if (< regn 0)
(setq lstfen (list c4 ll ul ur c3))
(setq lstfen (list c3 lr c4))
)
)
); end cond
(setq ssER (ssget "CP" lstfen))
(if ssER
(progn
(setq LenssER (SS-enlst ssER))
(if (member encur LenssER)
(setq LenssER (SS-enlst (ssdel encur ssER)))
)
(vla-put-visible objL :vlax-false)
(mapcar 'entdel LenssER)
)
)
(vla-put-visible objL :vlax-true)
(vlax-invoke-method ActDoc 'Regen acActiveViewport) ; regen
(command "undo" "end")
(acet-error-restore)
(setvar "pdmode" 35)
(princ)
(princ
"\nChuc cac ban may man va thanh cong - Thiep 0918841230"
)
(princ)
)
;;;====================================================================
(defun break_with (ss2brk enL / lst masterlist ss oc break_obj intpts)
(princ "\nCalculating Break Points, Please Wait.\n")

;;========================================
;; Break entity at break points in list
;;========================================

(defun break_obj (ent brkptlst / brkobjlst en
enttype maxparam closedobj minparam
obj obj2break p1param p2param
brkpt2 dlst idx brkptS
brkptE brkpt result result
ignore dist tmppt #ofpts
enddist lastent obj2break stdist
)
(setq obj2break ent
brkobjlst (list ent)
enttype (dxf 0 ent)
closedobj (vlax-curve-isclosed obj2break)
)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst
(mapcar
'(lambda (x)
(list
x
(vlax-curve-getdistatparam
obj2break
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint obj2break x)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
x
)
)
)
)
)
)
)
brkptlst
)
)
;; sort primary list on distance
(setq
brkptlst (vl-sort brkptlst
'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
)
)

;; -----------------------------------------------------

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(setq brkptS (car brkpt)
brkptE brkptS
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break tmppt)
)
)
)
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while
(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj tmppt)
)
)
(null (setq obj2break obj))
; switch objects, null causes exit
t
)
)
)
)
)
)
); end (if brkobjlst

;;; Handle any objects that can not be used with the Break Command
;;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
;;; single breakpoint ----------------------------------------------------
(if
(and closedobj
(not (setq
brkptE (vlax-curve-getPointAtDist
obj2break
(+ (vlax-curve-getdistatparam
obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond
((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
)
)
)
(setq
brkptE (vlax-curve-getPointAtDist
obj2break
(- (vlax-curve-getdistatparam
obj2break
(cond ((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
); end setq brkptE
); end fi (and closedobj

(setq LastEnt (GetLastEnt))
(command "._break"
obj2break
"_non"
(trans brkptS 0 1)
"_non"
(trans brkptE 0 1)
)
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast)))
)
(setq brkobjlst (cons (entlast) brkobjlst))
); end (if (and
); end (foreach brkpt (reverse brkptlst)
);end progn brkptlst
); end if brkptlst

); defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt (/ ename result)
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(if (and ss2brk enL)
(progn
(setq oc 0)
;; CREATE a list of entity & it's break points
(foreach en (SS-enlst ss2brk)
; check each object in ss2brk
(if (not (acet-layer-locked (dxf 8 en)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(if (and (not (equal en enint))
(setq intpts (acet-geom-intersectwith en enL 0))
)
(setq lst (append intpts lst))
; entity w/ break points
)
(princ (strcat "Objects Checked: "
(itoa (setq oc (1+ oc)))
"\r"
)
)
(if lst
(setq masterlist
(cons (cons en lst) masterlist)
)
)
)
)
)
(princ "\nBreaking Objects.\n")
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
(and
(setq objl (vlax-ename->vla-object en))
(setq
ss
(ssget
"_A"
(list
(cons 0
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
)
)
)
(setq lst (SS-enlst ss)
lst (mapcar 'vlax-ename->vla-object lst)
)
(mapcar
'(lambda (x)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith objl x acextendnone)
)
)
)
)
)
)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
)
lst
)
)
lstc
)

Chào anh Thiệp, tại sao trong lisp của anh thỉnh thoảng báo lỗi "bad argument type: lselsetp "? Anh có thể sửa lại để không bị lỗi này nữa được ko?
Thêm 1 điều nữa là tại sao khi đưởng thẳng chạy qua 1 bộ XREF và Hatch nào đó thì khi dùng lisp này nó lại xóa luôn cả bộ XREF và Hatch đó chứ ko còn là trim nữa?
Nhờ anh xem giúp, xin cảm ơn :bigsmile:
  • 0

#39 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 14 October 2009 - 01:37 PM

Chào anh Thiệp, tại sao trong lisp của anh thỉnh thoảng báo lỗi "bad argument type: lselsetp "? Anh có thể sửa lại để không bị lỗi này nữa được ko?
Thêm 1 điều nữa là tại sao khi đưởng thẳng chạy qua 1 bộ XREF và Hatch nào đó thì khi dùng lisp này nó lại xóa luôn cả bộ XREF và Hatch đó chứ ko còn là trim nữa?
Nhờ anh xem giúp, xin cảm ơn :bigsmile:

Chào study_foreve, bạn có thể gửi file DWG của bạn để Thiep xem trong bản vẽ của bạn có gì lạ không! Ví dụ, các đối tượng không đồng phẳng, đang bị khóa lớp, ...?
  • 0

#40 michoma

michoma

    biết zoom

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

Đã gửi 30 October 2009 - 09:39 PM

sao mình load cái lisp rồi dùng thử mà có thấy có thay đổi gì đâu . lệnh gọi là er2l đúng ko nhỉ .gọi xong nó ko cho mình chọn khung thì làm sao mà cắt nhỉ. ban Thiệp giải thích dùm mình đc ko vậy???
  • 0