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

Tháng 9 18, 2009

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

Tháng 9 18, 2009

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.

Tháng 9 18, 2009

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:

Tháng 9 18, 2009

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.

Tháng 9 18, 2009

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

file cad http://www.cadviet.com/upfiles/2/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?

Tháng 9 18, 2009

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.

Tháng 9 21, 2009

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.com/forum/index.php?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.com/upfiles/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.

Tháng 9 21, 2009

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:

Tháng 9 28, 2009

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.com/forum/index.php?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.com/upfiles/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
)

Tháng 9 28, 2009

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

Tháng 9 28, 2009

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:

Tháng 9 29, 2009

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

Tháng 10 14, 2009

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:

Tháng 10 14, 2009

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, ...?

Tháng 10 30, 2009

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

Tháng 10 30, 2009

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

Muốn làm được việc này mình nghĩ bạn phải viết đc một số hàm toán học như xác định điểm ở trong hay ngoài đa giác, giao của các đối tượng như đg thẳng, đg tròn ... với đa giác, sau đó xác định phần nằm trong hay ngài đa giác để cắt và xóa chúng đi. Có thể có những hàm đã có trong vl.

Tháng 10 31, 2009

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

Lisp này chỉ xóa các đối tượng ở miền 1 bên đường thẳng thôi, sau khi phát lệnh er2l, lisp sẽ hỏi chọn đường thẳng chặn, pick vào miền cần xoá, OK.

Tháng 10 31, 2009

Muốn làm được việc này mình nghĩ bạn phải viết đc một số hàm toán học như xác định điểm ở trong hay ngoài đa giác, giao của các đối tượng như đg thẳng, đg tròn ... với đa giác, sau đó xác định phần nằm trong hay ngài đa giác để cắt và xóa chúng đi. Có thể có những hàm đã có trong vl.

Thiep đã viết được thuật toán xác định được miền cần xóa giống như trong lệnh offset: pick điểm vào bên nào của curve cần offset.

Giao của các đối tượng thì cũng xử lý được, chỉ còn 1 loại đối tượng là hatch, Thiep đang nghiên cứu xử lý bằng cách nhờ hàm trim. Các block hay xref thì không thể được, vì đụng tới nó thì phải nổ nó ra.

Ngoài ra cái vất vả nhất là phải chia rất nhiều trường hợp vị trí và kiểu của curve, chỉ riêng curve là đường thẳng mà đã có 12 trường hợp rồi! Hiện giờ Thiep đang bận rộn với công việc, chưa rảnh tay sờ tới 1 lisp nào, cho Thiep nợ 1 thời gian nữa nhé. Nếu TRUNGNGAMY hoặc các bạn nào trên diễn đàn rảnh tay thì giúp cho Thiep chia hết các trường hợp ra (các điều kiện cho hàm cond) Thiep sẽ gắn mã lisp cho từng trường hợp.

Tháng 10 31, 2009

Thiep đã viết được thuật toán xác định được miền cần xóa giống như trong lệnh offset: pick điểm vào bên nào của curve cần offset.
Giao của các đối tượng thì cũng xử lý được, chỉ còn 1 loại đối tượng là hatch, Thiep đang nghiên cứu xử lý bằng cách nhờ hàm trim. Các block hay xref thì không thể được, vì đụng tới nó thì phải nổ nó ra.

Ngoài ra cái vất vả nhất là phải chia rất nhiều trường hợp vị trí và kiểu của curve, chỉ riêng curve là đường thẳng mà đã có 12 trường hợp rồi! Hiện giờ Thiep đang bận rộn với công việc, chưa rảnh tay sờ tới 1 lisp nào, cho Thiep nợ 1 thời gian nữa nhé. Nếu TRUNGNGAMY hoặc các bạn nào trên diễn đàn rảnh tay thì giúp cho Thiep chia hết các trường hợp ra (các điều kiện cho hàm cond) Thiep sẽ gắn mã lisp cho từng trường hợp.

Mình kg hiểu ý tưởng và các trường hợp mà Thiep nói. Mình nghĩ mấu chốt của vấn đề ở đây chỉ là tìm giao của 2 đối tg. nếu bạn đã tìm đc giao của hai dối tg rồi thì chỉ cần tìm các phần của đối tg bị cắt ra nằm ở trong hay ngoài đối tg cơ sở là đc. Giả sử một đường thẳng bị chia thành 3 đoạn, trên 1 đoạn ta lấy 1 điểm để xét, nếu điểm này nằm trong (hay ngoài) đối tượng cơ sở thì đoạn đó cũng sẽ nằm trong (hay ngoài) đối tượng cơ sở. Sau đó xét cho các TH cao hơn khi đối tg bị cắt là cung tròn, đg tròn, elip ... cũng làm tương tự.

Mình xin lỗi Thiep và các bạn là mình kg thể viết lisp này đc chỉ đơn giản là mình kg có kiến thức về vl. Vì trong vl có rất nhiều hàm hữu ích mà nếu kg có nó khó lòng viết đc lisp này. Mình chỉ tham gia ý tưởng xem có giúp gì đc cho Thiep kg thôi.

Tháng 10 31, 2009

Lisp này chỉ xóa các đối tượng ở miền 1 bên đường thẳng thôi, sau khi phát lệnh er2l, lisp sẽ hỏi chọn đường thẳng chặn, pick vào miền cần xoá, OK.

xin lỗi nhưng mình cũng chẳng thấy nó hỏi chọn đường thẳng để mà xoá nữa , gọi lệnh xong nó chạy ra cái dòng này :

Command: er2l

Free lisp from www.cadviet.comRegenerating model.

Break objects touching selected objects.

Select object(s) to break & press enter:

too many arguments

nghĩa là gì nhỉ :tongue2:

Tháng 10 31, 2009

xin lỗi nhưng mình cũng chẳng thấy nó hỏi chọn đường thẳng để mà xoá nữa , gọi lệnh xong nó chạy ra cái dòng này :
Command: er2l

Free lisp from www.cadviet.comRegenerating model.

Break objects touching selected objects.

Select object(s) to break & press enter:

too many arguments

nghĩa là gì nhỉ :tongue2:

Bạn đừng nhấn vào Download lisp file,bạn copy nội dung lisp rồi dán vào Notepad,sao lưu dưới định dạng er2l.lsp

Tháng 11 1, 2009

ko đc nó vẫn thế , ai biết chỉ dùm với :tongue2:

Tháng 3 11, 2012

Trong trường hợp xóa đối tượng ở giữa 2 đường thẳng lisp không đáp ứng được ?

Đăng nhập

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

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

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

nataca 554

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

nataca 554

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.553

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hai_1401 30

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hai_1401 30

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

study_forever 0

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

michoma 0

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thiep 365

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

michoma 0