Rated 5/5 based on 240179 internet user reviews

Jump to content


Change Photo
* * * - - 2 Phiếu

lisp xa tất cả cc đối tượng trong 1 vng kn


  • Please log in to reply
74 replies to this topic

#21 thiep

thiep

    biết dimdiameter

  • Members
  • PipPipPipPipPip
  • 331 posts
Danh tiếng: 247 (kh)

Gửi vào 01 July 2009 - 12:51 PM

Bc Thiếp ,,sory bc v lc đầu e chỉ gặp rắc rối với 1 curve, vấn đề về 2 curve l tưởng pht sinh m, hh...nhưng sao lisp ny khng kết hợp được với extrim giống như 1 curve hả bc thiep?nếu kết hợp được với extrim th tuyệt qu bc thip a!Thanks bc nhiều nhiều nha

C lẽ hẹn sau khi vắng mặt một thời gian, khi quay về TP, thiep sẽ thm extrim. Hoặc c thể nhờ bc Hoanh hoặc ai đ vậy.
  • 0

#22 namhai

namhai

    biết vẽ rectang

  • Members
  • PipPip
  • 81 posts
Danh tiếng: 18 (tm tạm)

Gửi vào 01 July 2009 - 01:43 PM

C lẽ hẹn sau khi vắng mặt một thời gian, khi quay về TP, thiep sẽ thm extrim. Hoặc c thể nhờ bc Hoanh hoặc ai đ vậy.

vng,chc bc c chuyến cng tc vui vẻ v thnh cng, mong được sự tiếp tục gip đỡ của bc cũng như của cadviet :s_big:
  • 2
Hy lm việc hết mnh rồi mọi điều tốt đẹp sẽ đến với bạn.....

#23 billgateviet

billgateviet

    biết vẽ pline

  • Members
  • PipPip
  • 63 posts
Danh tiếng: 29 (tm tạm)

Gửi vào 01 July 2009 - 02:29 PM

C lẽ hẹn sau khi vắng mặt một thời gian, khi quay về TP, thiep sẽ thm extrim. Hoặc c thể nhờ bc Hoanh hoặc ai đ vậy.

Đi cng tc xa chớ c ăn g rừng l "ngẻo cổ" đ nghe. Chc pc mnột chuyến cng tc ZUI ZẺ
  • 1

#24 xuandao0708

xuandao0708

    biết lệnh scale

  • Members
  • PipPipPip
  • 140 posts
Danh tiếng: 9 (bnh thường)

Gửi vào 01 July 2009 - 03:52 PM

Mong Bc Thiệp c một chuyến cng tc tốt đẹp v thuận lợi.
  • 0

#25 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 02 July 2009 - 09:12 AM

Nanhai , v ban đầu bạn chỉ yu cầu xa cc đối tượng trong 1 curve.
Sau đ th Nanhai yu cầu thm xa cc đối tượng ngoi 1 curve.
By giờ th yu cầu thm xa cc đối tượng giữa 2 curve, chứ khng c "hnh như" bạn ạ
...........
Lisp đ chỉnh sửa:

ERC.LSP free lisp from cadviet.com
;; copyright by Thiep,06/2009
................................

Cho cc bạn.
Về cơ bản th LISP ERC của bạn Thiệp đ giải quyết đuợc cc yu cầu xa cc đối tuợng trong, ngoi v giữa 2 đuờng bao.
Tuy nhin với cc đối tuợng c giao với đuờng bao th Lisp ERC chưa hon chỉnh.
Để giải quyết vấn đề xa cc đối tuợng c giao với đuờng bao, tui dng giải php l cắt cc đối tuợng ny tại giao điểm với đuờng bao, sử dụng hm break_with của CAB trn www.TheSwamp.org
Do hm break_with chỉ cắt cc đối tuợng lines, lwplines, plines, splines, ellipse, circles & arcs nn với cc đối tuợng cn lại như Text, Dimension,... LISP khng giải quyết triệt để. :s_big:

Cc bạn chạy thử v cho kiến. File
(defun c:EWB (/ ov vl ss1 ss2 ptLst plSet) ;EWB -> Erase With Boundary  (defun *error* (msg)        (if ov (mapcar 'setvar vl ov)) ; reset Sys vars    (princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message    (princ) ; Exit Cleanly    )  (command "_.undo" "_begin")  (setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list        ov (mapcar 'getvar vl)) ; Get Old values    (mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE  (initget "T N G")  (setq	bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao <T/N/G>: " ) )  (cond    ((= bit "T") ;xoa Trong duong bao     (princ"\n<<< Chon duong bao >>> ")     (if (and (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))	      (setq ssInside (GetssInside ss))	      (> (sslength ssInside) 0))       (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside))) ) ; xoa ssInside       )     )        ((= bit "G") ;xoa giua 2 duong bao     (princ"\n<<< Chon duong bao ngoai >>> ")     (setq ssN (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))     (princ"\n<<< Chon duong bao trong >>> ")     (setq ssT (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))	   curT (ssname ssT 0)	   ssT (GetssInside ssT)	   ssN (GetssInside ssN))     (if (and ssT (> (sslength ssT) 0) ssN (> (sslength ssN) 0) )       (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssT)))	 (if (ssmemb e ssN) (ssdel e ssN)))       )     (if (ssmemb curT ssN) (ssdel curT ssN))     (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssN))) ) ; xoa ss     )    ((= bit "N") ;xoa Ngoai duong bao     (initget "T G")     (setq bit (getkword "\nXoa Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao <T/G>: " ) )     (princ"\n<<< Chon duong bao >>> ")     (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))	   cur (ssname ss 0))     (if (= bit "T")       (progn ;xoa Tat ca doi tuong ngoai duong bao	 (setq ssInside (GetssInside ss)	       ssAll (ssget "x" (list (cons 410 (getvar "ctab")))) )	 (if (and ssInside (> (sslength ssInside) 0) )	   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))	     (if (ssmemb e ssAll) (ssdel e ssAll)))	   )	 (if (ssmemb cur ssAll) (ssdel cur ssAll))	 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssAll))) ) ; xoa ss	 )       ;chi xoa doi tuong Giao voi duong bao       (if (and (setq ssOutside (GetssOutside ss))		(> (sslength ssOutside) 0))	 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssOutside))) ) ; xoa ssOutside	 )       );if     );;xoa Ngoai duong bao    );cond  (mapcar 'setvar vl ov) ; reset Sys Vars  (command "_.undo" "_end")  (princ))(defun GetssOutside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)    (if (and (setq lstss1 (gettouching ss2))	   (setq ss1 (ssadd))	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)	   )    (progn ; co ssTouching       (break_with ss1 ss2 nil 0)      (setq cur (ssname ss2 0)	    ssTouching (ssadd)	    ssOutside (ssadd))      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))      ;loc ssTouching -> ssOutside      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))	(if	  (or	    (not(insidep (vlax-curve-getStartPoint e) cur))	    (not(insidep (vlax-curve-getEndPoint e) cur))	    (not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))	    );or	  (ssadd e ssOutside)	  );if	);foreach      );progn    );if  (if (ssmemb cur ssOutside) (ssdel cur ssOutside))  ssOutside  )(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)  (setq ptLst (GetPtLst (setq cur (ssname ss2 0)))	ssInside (ssget "_WP" ptLst ) )    (if (and (setq lstss1 (gettouching ss2))	   (setq ss1 (ssadd))	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)	   )    (progn ; co ssTouching      (break_with ss1 ss2 nil 0)      (setq ssTouching (ssadd))      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))      ;loc ssTouching -> ssInside      (or ssInside (setq ssInside (ssadd)) )      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))	(if	  (and (insidep (vlax-curve-getStartPoint e) cur)	       (insidep (vlax-curve-getEndPoint e) cur)	       (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2))  cur)	       )	  (ssadd e ssInside)	  );if	);foreach      );progn    );if  (if (ssmemb cur ssInside) (ssdel cur ssInside))  ssInside  ) (defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)  (defun ZClosed (lst)    (if (and (vlax-curve-isClosed obj)       (not(equal (car lst)(last lst) 1e-6)))      (append lst (list (car lst)))      lst))    (or (eq (type obj) 'VLA-OBJECT)    (setq obj (vlax-ename->vla-object obj)))  (setq typ (vlax-get obj 'ObjectName))  (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))    (progn      (setq param 0)      (while (< param (* pi 2))	(setq pt (vlax-curve-getPointAtParam obj param)	      ptlst (cons pt ptlst)	      param (+ (/ (* pi 2) 72) param))	)      (reverse ptlst)      )    (progn ;Pline (eq typ "AcDbPolyline")      (setq param (vlax-curve-getStartParam obj)	    endparam (vlax-curve-getEndParam obj)	    anginc (* pi (/ 7.5 180.0)))      (setq tparam param)      (while (<= param endparam)	(setq pt (vlax-curve-getPointAtParam obj param))	(if (not (equal pt (car ptlst) 1e-12))	  (setq ptlst (cons pt ptlst)))	(if  (and (/= param endparam)		  (setq blg (abs (vlax-invoke obj 'GetBulge param)))		  (/= 0 blg))	  (progn	    (setq delta (* 4 (atan blg)) ;included angle		  inc (/ 1.0 (1+ (fix (/ delta anginc))))                  arcparam (+ param inc))	    (while (< arcparam (1+ param))	      (setq pt (vlax-curve-getPointAtParam obj arcparam)                    ptlst (cons pt ptlst)                    arcparam (+ inc arcparam))))	  )	(setq param (1+ param))	)      (if (and (apply 'and ptlst)	       (> (length ptlst) 1))	(ZClosed (reverse ptlst))	)      )    )  );;  Copyright © 2009, Lee McDonnell;;  (Contact Lee Mac, CADTutor.net)(defun insidep  (pt Obj / Obj Tol ang doc spc flag int lin xV yV)  (defun vlax-list->3D-point (lst flag)  (if lst    (cons ((if flag car cadr) lst)          (vlax-list->3D-point (cdddr lst) flag))))  (or (eq 'VLA-OBJECT (type Obj))      (setq Obj (vlax-ename->vla-object Obj)))  (if (not(vlax-curve-getParamAtPoint Obj pt))    (progn  (setq Tol  (/ pi 6) ; Uncertainty        ang  0.0 flag T)  (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))        spc (if (zerop (vla-get-activespace doc))              (if (= (vla-get-mspace doc) :vlax-true)                (vla-get-modelspace doc)                (vla-get-paperspace doc))              (vla-get-modelspace doc)))  (while (and (< ang (* 2 pi)) flag)    (setq flag (and                 (setq int                   (vlax-invoke                     (setq lin                       (vla-addLine spc                         (vlax-3D-point pt)                           (vlax-3D-point                             (polar pt ang                               (if (vlax-property-available-p Obj 'length)                                 (vla-get-length Obj) 1.0)))))                                  'IntersectWith Obj                                    acExtendThisEntity))                 (<= 6 (length int))                 (setq xV (vl-sort (vlax-list->3D-point int T) '<)                       yV (vl-sort (vlax-list->3D-point int nil) '<))                 (or (<= (car xV) (car pt) (last xV))                     (<= (car yV) (cadr pt) (last yV))))          ang  (+ ang Tol))    (vla-delete lin))  flag  )    T    ));;; Author: Copyrightゥ 2006-2008 Charles Alan Butler ;;; Contact @  www.TheSwamp.org;;===========================================================================  ;;  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 (sscros / ss lst lstb lstc objl)    (and      (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))            objl (mapcar 'vlax-ename->vla-object lstb)      )      (setq ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")				 (cons 410 (getvar "ctab"))))      )      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))      (setq lst (mapcar 'vlax-ename->vla-object lst))      (mapcar        '(lambda (x)           (mapcar             '(lambda (y)                (if (not                      (vl-catch-all-error-p                        (vl-catch-all-apply                          '(lambda ()                             (vlax-safearray->list                               (vlax-variant-value                                 (vla-intersectwith y x acextendnone)                               ))))))                  (setq lstc (cons (vlax-vla-object->ename x) lstc))                )              ) objl)         ) lst)    )    lstc  );;; Author: Copyrightゥ 2006-2008 Charles Alan Butler ;;; Contact @  www.TheSwamp.org(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs                   onlockedlayer ssget->vla-list list->3pair GetNewEntities oc                   get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList                  )  ;; ss2brk     selection set to break  ;; ss2brkwith selection set to use as break points  ;; self       when true will allow an object to break itself  ;;            note that plined will break at each vertex  ;;  ;; return list of enames of new objects    (vl-load-com)    (princ "\nCalculating Break Points, Please Wait.\n");;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++;;                S U B   F U N C T I O N S                      ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  ;;  return T if entity is on a locked layer  (defun onlockedlayer (ename / entlst)    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))    (= 4 (logand 4 (cdr (assoc 70 entlst))))  )  ;;  return a list of objects from a selection set;|  (defun ssget->vla-list (ss)    (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))  )|;  (defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7       (setq i -1)       (while (setq  ename (ssname ss (setq i (1+ i))))         (setq allobj (cons (vlax-ename->vla-object ename) allobj))       )       allobj  )    ;;  return a list of lists grouped by 3 from a flat list  (defun list->3pair (old / new)    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)                 old (cdddr old)))    (reverse new)  )  ;;=====================================;;  return a list of intersect points  ;;=====================================(defun get_interpts (obj1 obj2 / iplist)  (if (not (vl-catch-all-error-p             (setq iplist (vl-catch-all-apply                            'vlax-safearray->list                            (list                              (vlax-variant-value                                (vla-intersectwith obj1 obj2 acextendnone)                              ))))))    iplist  ));;========================================;;  Break entity at break points in list  ;;========================================(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS                  brkptE brkpt result GapFlg result ignore dist tmppt                  #ofpts 2gap enddist lastent obj2break stdist                 )  (or BrkGap (setq BrkGap 0.0)) ; default to 0  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point    (setq obj2break ent        brkobjlst (list ent)        enttype   (cdr (assoc 0 (entget ent)))        GapFlg    (not (zerop BrkGap)) ; gap > 0        closedobj (vlax-curve-isclosed obj2break)  )  ;; when zero gap no need to break at end points  (if (zerop Brkgap)    (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 GapFlg ; gap > 0    ;; Brkptlst starts as the break point and then a list of pairs of points    ;;  is creates as the break points    (progn      ;;  create a list of list of break points      ;;  ((idx# stpoint distance)(idx# endpoint distance)...)      (setq idx 0)      (foreach brkpt brkptlst                ;; ----------------------------------------------------------        ;;  create start break point, then create end break point            ;;  ((idx# startpoint distance)(idx# endpoint distance)...)          ;; ----------------------------------------------------------        (setq dist (cadr brkpt)) ; distance to center of gap        ;;  subtract gap to get start point of break gap        (cond          ((and (minusp (setq stDist (- dist BrkGap))) closedobj )           (setq stdist (+ (vlax-curve-getdistatparam obj2break                             (vlax-curve-getendparam obj2break)) stDist))           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))           )          ((minusp stDist) ; off start of object so get startpoint           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))           )          (t           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))          )        )        ;;  add gap to get end point of break gap        (cond          ((and (> (setq stDist (+ dist BrkGap))                   (setq endDist (vlax-curve-getdistatparam obj2break                                     (vlax-curve-getendparam obj2break)))) closedobj )           (setq stdist (- stDist endDist))           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))           )          ((> stDist endDist) ; off end of object so get endpoint           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                        (vlax-curve-getendparam obj2break))                                  endDist) dlst))           )          (t           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))          )        )        ;; -------------------------------------------------------        (setq idx (1+ IDX))      ) ; foreach brkpt brkptlst            (setq dlst (reverse dlst))      ;;  remove the points of the gap segments that overlap      (setq idx -1            2gap (* BrkGap 2)            #ofPts (length Brkptlst)      )      (while (<= (setq idx (1+ idx)) #ofPts)        (cond          ((null result) ; 1st time through           (setq result (list (car dlst)) ; get first start point                 result (cons (nth (1+(* idx 2)) dlst) result))          )          ((= idx #ofPts) ; last pass, check for wrap           (if (and closedobj (> #ofPts 1)                    (<= (+(- (vlax-curve-getdistatparam obj2break                            (vlax-curve-getendparam obj2break))                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))             (progn               (if (zerop (rem (length result) 2))                 (setq result (cdr result)) ; remove the last end point               )               ;;  ignore previous endpoint and present start point               (setq result (cons (cadr (reverse result)) result) ; get last end point                     result (cdr (reverse result))                     result (reverse (cdr result)))             )           )          )          ;; Break Gap Overlaps          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))           (if (zerop (rem (length result) 2))             (setq result (cdr result)) ; remove the last end point           )           ;;  ignore previous endpoint and present start point           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point           )          ;; Break Gap does Not Overlap previous point           (t           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point          )        ) ; end cond stmt      ) ; while            (setq dlst     (reverse result)            brkptlst nil)      (while dlst ; grab the points only        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)              dlst   (cddr dlst))      )    )  )  ;;   -----------------------------------------------------  ;; (if (equal  a ent) (princ)) ; debug CAB  -------------   (foreach brkpt (reverse brkptlst)    (if GapFlg ; gap > 0      (setq brkptS (car brkpt)            brkptE (cadr brkpt))      (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                        )                   )            )          )        )      )    )    (setq closedobj (vlax-curve-isclosed obj2break))    (if GapFlg ; gap > 0      (if closedobj        (progn ; need to break a closed object          (setq brkpt2 (vlax-curve-getPointAtDist obj2break                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))          (command "._break" obj2break "_non" (trans brkpt2 0 1)                   "_non" (trans brkptE 0 1))          (and (= "CIRCLE" enttype) (setq enttype "ARC"))          (setq BrkptE brkpt2)        )      )      (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                            ;;(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)))       )    ) ; endif        ;; (if (null brkptE) (princ)) ; debug        (setq LastEnt (GetLastEnt))    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))    (and (= "CIRCLE" enttype) (setq enttype "ARC"))    (if (and (not closedobj) ; new object was created             (not (equal LastEnt (entlast))))        (setq brkobjlst (cons (entlast) brkobjlst))    )  )  )  ) ; endif 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);;===================================;;  CAB - return a list of new enames(defun GetNewEntities (ename / new)  (cond    ((null ename) (alert "Ename nil"))    ((eq 'ENAME (type ename))      (while (setq ename (entnext ename))        (if (entget ename) (setq new (cons ename new)))      )    )    ((alert "Ename wrong type."))  )  new)    ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  ;;         S T A R T  S U B R O U T I N E   H E R E                ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++       (setq LastEntInDatabase (GetLastEnt))    (if (and ss2brk ss2brkwith)    (progn      (setq oc 0            ss2brkwithList (ssget->vla-list ss2brkwith))      (if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)        (setq *BrkVerbose* t)      )      (and *BrkVerbose*           (princ (strcat "Objects to be Checked: "            (itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))      ;;  CREATE a list of entity & it's break points      (foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk        (if (not (onlockedlayer (vlax-vla-object->ename obj)))          (progn            (setq lst nil)            ;; check for break pts with other objects in ss2brkwith            (foreach intobj  ss2brkwithList              (if (and (or self (not (equal obj intobj)))                       (setq intpts (get_interpts obj intobj))                  )                (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points              )              (and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))            )            (if lst              (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))            )          )        )      )          (and *BrkVerbose* (princ "\nBreaking Objects.\n"))      (setq *brkcnt* 0) ; break counter      ;;  masterlist = ((ent brkpts)(ent brkpts)...)      (if masterlist        (foreach obj2brk masterlist          (break_obj (car obj2brk) (cdr obj2brk) Gap)        )      )      )  );;==============================================================   (and (zerop *brkcnt*) (princ "\nNone to be broken."))   (setq *BrkVerbose* nil)  (GetNewEntities LastEntInDatabase) ; return list of enames of new objects)

  • 6

#26 nataca

nataca

    biết lệnh adcenter

  • CVN Team
  • PipPipPipPipPipPipPip
  • 712 posts
Danh tiếng: 541 (tốt)

Gửi vào 02 July 2009 - 09:52 AM

Cho cc bạn.
Về cơ bản th LISP ERC của bạn Thiệp đ giải quyết đuợc cc yu cầu xa cc đối tuợng trong, ngoi v giữa 2 đuờng bao.
Tuy nhin với cc đối tuợng c giao với đuờng bao th Lisp ERC chưa hon chỉnh.
Để giải quyết vấn đề xa cc đối tuợng c giao với đuờng bao, tui dng giải php l cắt cc đối tuợng ny tại giao điểm với đuờng bao, sử dụng hm break_with của CAB trn www.TheSwamp.org
Do hm break_with chỉ cắt cc đối tuợng lines, lwplines, plines, splines, ellipse, circles & arcs nn với cc đối tuợng cn lại như Text, Dimension,... LISP khng giải quyết triệt để. :s_big:

Cc bạn chạy thử v cho kiến.

(defun c:EWB (/ ov vl ss1 ss2 ptLst plSet) ;EWB -> Erase With Boundary  (defun *error* (msg)        (if ov (mapcar 'setvar vl ov)) ; reset Sys vars    (princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message    (princ) ; Exit Cleanly    )  (command "_.undo" "_begin")  (setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list        ov (mapcar 'getvar vl)) ; Get Old values    (mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE  (initget "T N G")  (setq	bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao <T/N/G>: " ) )  (cond    ((= bit "T") ;xoa Trong duong bao     (princ"\n<<< Chon duong bao >>> ")     (if (and (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))	      (setq ssInside (GetssInside ss))	      (> (sslength ssInside) 0))       (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside))) ) ; xoa ssInside       )     )        ((= bit "G") ;xoa giua 2 duong bao     (princ"\n<<< Chon duong bao ngoai >>> ")     (setq ssN (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))     (princ"\n<<< Chon duong bao trong >>> ")     (setq ssT (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))	   curT (ssname ssT 0)	   ssT (GetssInside ssT)	   ssN (GetssInside ssN))     (if (and ssT (> (sslength ssT) 0) ssN (> (sslength ssN) 0) )       (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssT)))	 (if (ssmemb e ssN) (ssdel e ssN)))       )     (if (ssmemb curT ssN) (ssdel curT ssN))     (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssN))) ) ; xoa ss     )    ((= bit "N") ;xoa Ngoai duong bao     (initget "T G")     (setq bit (getkword "\nXoa Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao <T/G>: " ) )     (princ"\n<<< Chon duong bao >>> ")     (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))	   cur (ssname ss 0))     (if (= bit "T")       (progn ;xoa Tat ca doi tuong ngoai duong bao	 (setq ssInside (GetssInside ss)	       ssAll (ssget "x" (list (cons 410 (getvar "ctab")))) )	 (if (and ssInside (> (sslength ssInside) 0) )	   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))	     (if (ssmemb e ssAll) (ssdel e ssAll)))	   )	 (if (ssmemb cur ssAll) (ssdel cur ssAll))	 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssAll))) ) ; xoa ss	 )       ;chi xoa doi tuong Giao voi duong bao       (if (and (setq ssOutside (GetssOutside ss))		(> (sslength ssOutside) 0))	 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssOutside))) ) ; xoa ssOutside	 )       );if     );;xoa Ngoai duong bao    );cond  (mapcar 'setvar vl ov) ; reset Sys Vars  (command "_.undo" "_end")  (princ))(defun GetssOutside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)    (if (and (setq lstss1 (gettouching ss2))	   (setq ss1 (ssadd))	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)	   )    (progn ; co ssTouching       (break_with ss1 ss2 nil 0)      (setq cur (ssname ss2 0)	    ssTouching (ssadd)	    ssOutside (ssadd))      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))      ;loc ssTouching -> ssOutside      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))	(if	  (or	    (not(insidep (vlax-curve-getStartPoint e) cur))	    (not(insidep (vlax-curve-getEndPoint e) cur))	    (not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)                              (vlax-curve-getEndParam e))2)) cur))	    );or	  (ssadd e ssOutside)	  );if	);foreach      );progn    );if  (if (ssmemb cur ssOutside) (ssdel cur ssOutside))  ssOutside  )(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)  (setq ptLst (GetPtLst (setq cur (ssname ss2 0)))	ssInside (ssget "_WP" ptLst ) )    (if (and (setq lstss1 (gettouching ss2))	   (setq ss1 (ssadd))	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)	   )    (progn ; co ssTouching      (break_with ss1 ss2 nil 0)      (setq ssTouching (ssadd))      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))      ;loc ssTouching -> ssInside      (or ssInside (setq ssInside (ssadd)) )      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))	(if	  (and (insidep (vlax-curve-getStartPoint e) cur)	       (insidep (vlax-curve-getEndPoint e) cur)	       (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)                           (vlax-curve-getEndParam e))2))  cur)	       )	  (ssadd e ssInside)	  );if	);foreach      );progn    );if  (if (ssmemb cur ssInside) (ssdel cur ssInside))  ssInside  ) (defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)  (defun ZClosed (lst)    (if (and (vlax-curve-isClosed obj)       (not(equal (car lst)(last lst) 1e-6)))      (append lst (list (car lst)))      lst))    (or (eq (type obj) 'VLA-OBJECT)    (setq obj (vlax-ename->vla-object obj)))  (setq typ (vlax-get obj 'ObjectName))  (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))    (progn      (setq param 0)      (while (< param (* pi 2))	(setq pt (vlax-curve-getPointAtParam obj param)	      ptlst (cons pt ptlst)	      param (+ (/ (* pi 2) 72) param))	)      (reverse ptlst)      )    (progn ;Pline (eq typ "AcDbPolyline")      (setq param (vlax-curve-getStartParam obj)	    endparam (vlax-curve-getEndParam obj)	    anginc (* pi (/ 7.5 180.0)))      (setq tparam param)      (while (<= param endparam)	(setq pt (vlax-curve-getPointAtParam obj param))	(if (not (equal pt (car ptlst) 1e-12))	  (setq ptlst (cons pt ptlst)))	(if  (and (/= param endparam)		  (setq blg (abs (vlax-invoke obj 'GetBulge param)))		  (/= 0 blg))	  (progn	    (setq delta (* 4 (atan blg)) ;included angle		  inc (/ 1.0 (1+ (fix (/ delta anginc))))                  arcparam (+ param inc))	    (while (< arcparam (1+ param))	      (setq pt (vlax-curve-getPointAtParam obj arcparam)                    ptlst (cons pt ptlst)                    arcparam (+ inc arcparam))))	  )	(setq param (1+ param))	)      (if (and (apply 'and ptlst)	       (> (length ptlst) 1))	(ZClosed (reverse ptlst))	)      )    )  );;  Copyright  2009, Lee McDonnell;;  (Contact Lee Mac, CADTutor.net)(defun insidep  (pt Obj / Obj Tol ang doc spc flag int lin xV yV)  (defun vlax-list->3D-point (lst flag)  (if lst    (cons ((if flag car cadr) lst)          (vlax-list->3D-point (cdddr lst) flag))))  (or (eq 'VLA-OBJECT (type Obj))      (setq Obj (vlax-ename->vla-object Obj)))  (if (not(vlax-curve-getParamAtPoint Obj pt))    (progn  (setq Tol  (/ pi 6) ; Uncertainty        ang  0.0 flag T)  (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))        spc (if (zerop (vla-get-activespace doc))              (if (= (vla-get-mspace doc) :vlax-true)                (vla-get-modelspace doc)                (vla-get-paperspace doc))              (vla-get-modelspace doc)))  (while (and (< ang (* 2 pi)) flag)    (setq flag (and                 (setq int                   (vlax-invoke                     (setq lin                       (vla-addLine spc                         (vlax-3D-point pt)                           (vlax-3D-point                             (polar pt ang                               (if (vlax-property-available-p Obj 'length)                                 (vla-get-length Obj) 1.0)))))                                  'IntersectWith Obj                                    acExtendThisEntity))                 (<= 6 (length int))                 (setq xV (vl-sort (vlax-list->3D-point int T) '<)                       yV (vl-sort (vlax-list->3D-point int nil) '<))                 (or (<= (car xV) (car pt) (last xV))                     (<= (car yV) (cadr pt) (last yV))))          ang  (+ ang Tol))    (vla-delete lin))  flag  )    T    ));;; Author: Copyrightゥ 2006-2008 Charles Alan Butler ;;; Contact @  www.TheSwamp.org;;===========================================================================  ;;  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 (sscros / ss lst lstb lstc objl)    (and      (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))            objl (mapcar 'vlax-ename->vla-object lstb)      )      (setq ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")				 (cons 410 (getvar "ctab"))))      )      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))      (setq lst (mapcar 'vlax-ename->vla-object lst))      (mapcar        '(lambda (x)           (mapcar             '(lambda (y)                (if (not                      (vl-catch-all-error-p                        (vl-catch-all-apply                          '(lambda ()                             (vlax-safearray->list                               (vlax-variant-value                                 (vla-intersectwith y x acextendnone)                               ))))))                  (setq lstc (cons (vlax-vla-object->ename x) lstc))                )              ) objl)         ) lst)    )    lstc  );;; Author: Copyrightゥ 2006-2008 Charles Alan Butler ;;; Contact @  www.TheSwamp.org(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs                   onlockedlayer ssget->vla-list list->3pair GetNewEntities oc                   get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList                  )  ;; ss2brk     selection set to break  ;; ss2brkwith selection set to use as break points  ;; self       when true will allow an object to break itself  ;;            note that plined will break at each vertex  ;;  ;; return list of enames of new objects    (vl-load-com)    (princ "\nCalculating Break Points, Please Wait.\n");;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++;;                S U B   F U N C T I O N S                      ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  ;;  return T if entity is on a locked layer  (defun onlockedlayer (ename / entlst)    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))    (= 4 (logand 4 (cdr (assoc 70 entlst))))  )  ;;  return a list of objects from a selection set;|  (defun ssget->vla-list (ss)    (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))  )|;  (defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7       (setq i -1)       (while (setq  ename (ssname ss (setq i (1+ i))))         (setq allobj (cons (vlax-ename->vla-object ename) allobj))       )       allobj  )    ;;  return a list of lists grouped by 3 from a flat list  (defun list->3pair (old / new)    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)                 old (cdddr old)))    (reverse new)  )  ;;=====================================;;  return a list of intersect points  ;;=====================================(defun get_interpts (obj1 obj2 / iplist)  (if (not (vl-catch-all-error-p             (setq iplist (vl-catch-all-apply                            'vlax-safearray->list                            (list                              (vlax-variant-value                                (vla-intersectwith obj1 obj2 acextendnone)                              ))))))    iplist  ));;========================================;;  Break entity at break points in list  ;;========================================(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS                  brkptE brkpt result GapFlg result ignore dist tmppt                  #ofpts 2gap enddist lastent obj2break stdist                 )  (or BrkGap (setq BrkGap 0.0)) ; default to 0  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point    (setq obj2break ent        brkobjlst (list ent)        enttype   (cdr (assoc 0 (entget ent)))        GapFlg    (not (zerop BrkGap)) ; gap > 0        closedobj (vlax-curve-isclosed obj2break)  )  ;; when zero gap no need to break at end points  (if (zerop Brkgap)    (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 GapFlg ; gap > 0    ;; Brkptlst starts as the break point and then a list of pairs of points    ;;  is creates as the break points    (progn      ;;  create a list of list of break points      ;;  ((idx# stpoint distance)(idx# endpoint distance)...)      (setq idx 0)      (foreach brkpt brkptlst                ;; ----------------------------------------------------------        ;;  create start break point, then create end break point            ;;  ((idx# startpoint distance)(idx# endpoint distance)...)          ;; ----------------------------------------------------------        (setq dist (cadr brkpt)) ; distance to center of gap        ;;  subtract gap to get start point of break gap        (cond          ((and (minusp (setq stDist (- dist BrkGap))) closedobj )           (setq stdist (+ (vlax-curve-getdistatparam obj2break                             (vlax-curve-getendparam obj2break)) stDist))           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))           )          ((minusp stDist) ; off start of object so get startpoint           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))           )          (t           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))          )        )        ;;  add gap to get end point of break gap        (cond          ((and (> (setq stDist (+ dist BrkGap))                   (setq endDist (vlax-curve-getdistatparam obj2break                                     (vlax-curve-getendparam obj2break)))) closedobj )           (setq stdist (- stDist endDist))           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))           )          ((> stDist endDist) ; off end of object so get endpoint           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                        (vlax-curve-getendparam obj2break))                                  endDist) dlst))           )          (t           (setq dlst (cons (list idx                                  (vlax-curve-getpointatparam obj2break                                         (vlax-curve-getparamatdist obj2break stDist))                                  stDist) dlst))          )        )        ;; -------------------------------------------------------        (setq idx (1+ IDX))      ) ; foreach brkpt brkptlst            (setq dlst (reverse dlst))      ;;  remove the points of the gap segments that overlap      (setq idx -1            2gap (* BrkGap 2)            #ofPts (length Brkptlst)      )      (while (<= (setq idx (1+ idx)) #ofPts)        (cond          ((null result) ; 1st time through           (setq result (list (car dlst)) ; get first start point                 result (cons (nth (1+(* idx 2)) dlst) result))          )          ((= idx #ofPts) ; last pass, check for wrap           (if (and closedobj (> #ofPts 1)                    (<= (+(- (vlax-curve-getdistatparam obj2break                            (vlax-curve-getendparam obj2break))                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))             (progn               (if (zerop (rem (length result) 2))                 (setq result (cdr result)) ; remove the last end point               )               ;;  ignore previous endpoint and present start point               (setq result (cons (cadr (reverse result)) result) ; get last end point                     result (cdr (reverse result))                     result (reverse (cdr result)))             )           )          )          ;; Break Gap Overlaps          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))           (if (zerop (rem (length result) 2))             (setq result (cdr result)) ; remove the last end point           )           ;;  ignore previous endpoint and present start point           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point           )          ;; Break Gap does Not Overlap previous point           (t           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point          )        ) ; end cond stmt      ) ; while            (setq dlst     (reverse result)            brkptlst nil)      (while dlst ; grab the points only        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)              dlst   (cddr dlst))      )    )  )  ;;   -----------------------------------------------------  ;; (if (equal  a ent) (princ)) ; debug CAB  -------------   (foreach brkpt (reverse brkptlst)    (if GapFlg ; gap > 0      (setq brkptS (car brkpt)            brkptE (cadr brkpt))      (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                        )                   )            )          )        )      )    )    (setq closedobj (vlax-curve-isclosed obj2break))    (if GapFlg ; gap > 0      (if closedobj        (progn ; need to break a closed object          (setq brkpt2 (vlax-curve-getPointAtDist obj2break                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))          (command "._break" obj2break "_non" (trans brkpt2 0 1)                   "_non" (trans brkptE 0 1))          (and (= "CIRCLE" enttype) (setq enttype "ARC"))          (setq BrkptE brkpt2)        )      )      (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                            ;;(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)))       )    ) ; endif        ;; (if (null brkptE) (princ)) ; debug        (setq LastEnt (GetLastEnt))    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))    (and (= "CIRCLE" enttype) (setq enttype "ARC"))    (if (and (not closedobj) ; new object was created             (not (equal LastEnt (entlast))))        (setq brkobjlst (cons (entlast) brkobjlst))    )  )  )  ) ; endif 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);;===================================;;  CAB - return a list of new enames(defun GetNewEntities (ename / new)  (cond    ((null ename) (alert "Ename nil"))    ((eq 'ENAME (type ename))      (while (setq ename (entnext ename))        (if (entget ename) (setq new (cons ename new)))      )    )    ((alert "Ename wrong type."))  )  new)    ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  ;;         S T A R T  S U B R O U T I N E   H E R E                ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++       (setq LastEntInDatabase (GetLastEnt))    (if (and ss2brk ss2brkwith)    (progn      (setq oc 0            ss2brkwithList (ssget->vla-list ss2brkwith))      (if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)        (setq *BrkVerbose* t)      )      (and *BrkVerbose*           (princ (strcat "Objects to be Checked: "            (itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))      ;;  CREATE a list of entity & it's break points      (foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk        (if (not (onlockedlayer (vlax-vla-object->ename obj)))          (progn            (setq lst nil)            ;; check for break pts with other objects in ss2brkwith            (foreach intobj  ss2brkwithList              (if (and (or self (not (equal obj intobj)))                       (setq intpts (get_interpts obj intobj))                  )                (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points              )              (and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))            )            (if lst              (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))            )          )        )      )          (and *BrkVerbose* (princ "\nBreaking Objects.\n"))      (setq *brkcnt* 0) ; break counter      ;;  masterlist = ((ent brkpts)(ent brkpts)...)      (if masterlist        (foreach obj2brk masterlist          (break_obj (car obj2brk) (cdr obj2brk) Gap)        )      )      )  );;==============================================================   (and (zerop *brkcnt*) (princ "\nNone to be broken."))   (setq *BrkVerbose* nil)  (GetNewEntities LastEntInDatabase) ; return list of enames of new objects)

Mnh đ chạy thử v c thng bo như sau: << Error: too many arguments >>
Chắc l trong qu trnh copy ln diễn đn bị lỗi. Bc c thể gửi km lun file được khng?
  • 0

#27 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 02 July 2009 - 10:00 AM

Mnh đ chạy thử v c thng bo như sau: << Error: too many arguments >>
Chắc l trong qu trnh copy ln diễn đn bị lỗi. Bc c thể gửi km lun file được khng?

Cho Nataca
Bạn dng chức năng Dowload file của diễn đn, sau đ xa dng .../t/g ... /t/n/g..." tại cuối file EWB.lsp
hay download file
Nhờ Admin xem lại chức năng Dowload file.
(setq bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao... /t/n/g...: " ) )
(setq bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao (T/N/G): " ) )
Thanks
  • 3

#28 namhai

namhai

    biết vẽ rectang

  • Members
  • PipPip
  • 81 posts
Danh tiếng: 18 (tm tạm)

Gửi vào 02 July 2009 - 11:10 AM

bc Gia Bach , sao e khng thể xo được cc đối tượng l đường đồng mức?e đang lm bnh đồ, muốn xo cc đường đng mức nằm ngoi 1 vng kn nhưng chỉ xo được cc đối tượng khc thi, cn với đường đồng mức th khng lm được.c phải v cc đường đồng mức c thuộc tnh g khc với cc đường pline bnh thường?
  • 1
Hy lm việc hết mnh rồi mọi điều tốt đẹp sẽ đến với bạn.....

#29 xuandao0708

xuandao0708

    biết lệnh scale

  • Members
  • PipPipPip
  • 140 posts
Danh tiếng: 9 (bnh thường)

Gửi vào 02 July 2009 - 11:10 AM

Thank Bc gia bach nhiều. Sau khi text thử th n chạy rất tuyệt tương đương như lệnh đng Fence bn Micro, nay em nhờ Bc c thể viết thm 1 lệnh tương tự như lệnh Ewb nhưng lần ny l n khng xo m chỉ cho mnh chọn đối tượng thi. Thank c Bc nhiều. :s_big:
  • 0

#30 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 02 July 2009 - 12:46 PM

Thank Bc gia bach nhiều. Sau khi text thử th n chạy rất tuyệt tương đương như lệnh đng Fence bn Micro, nay em nhờ Bc c thể viết thm 1 lệnh tương tự như lệnh Ewb nhưng lần ny l n khng xo m chỉ cho mnh chọn đối tượng thi. Thank c Bc nhiều. :s_big:

Cho xuandao0708
Bạn chạy thử Lisp chọn đối tuợng với đuờng bao : SWB
dowload here
  • 1

#31 namhai

namhai

    biết vẽ rectang

  • Members
  • PipPip
  • 81 posts
Danh tiếng: 18 (tm tạm)

Gửi vào 02 July 2009 - 02:00 PM

Cho namhai
Theo suy đon của tui : cc đuờng đồng mức c cao độ khc nhau -> khng c giao với đuờng bao, do đ LISP khng xa cc đuờng ny.

E nghĩ khi chuyển sang CAD th cc đường đồng mức cũng l 1 đối tượng của CAD chứ?Nếu explode đường đồng mức th xo bnh thường bc a, c phải trong đường đng mức trong trường hợp ny được hiểu l 1 block, v cũng khng copy=>paste clip được?nhưng lại trim được, điều ny lại tri ngược với giả thuyết n l 1 block?Vậy c cch no giải quyết được vấn đề ny khng , mong cc cao thủ gip đỡ? e lm thiết kế đường, vẽ đường mặt bằng tuyến trn bnh đồ v muốn xo cc đường đồng mức trong mặt bằng tuyến đấy, lm thủ cng rất mất thời gian.
  • 1
Hy lm việc hết mnh rồi mọi điều tốt đẹp sẽ đến với bạn.....

#32 xuandao0708

xuandao0708

    biết lệnh scale

  • Members
  • PipPipPip
  • 140 posts
Danh tiếng: 9 (bnh thường)

Gửi vào 02 July 2009 - 02:59 PM

C mơn Bc Gia Bach nhiều, lisp lệnh swb chưa chạy đng em lắm v khi chọn đối tượng trong vng kn để copy ra ring th bản vẽ chnh của mnh bị ph nt ngay vng kn mnh chọn. Khng biết Bc c giải php no để khi chọn cc đối tượng trong 1 vng kn dng lệnh copy th bản vẽ chnh của mnh khng bị ph nt như khi dng lệnh SWB. Thank Bc nhiều.
Đy l file cad mẫu:
http://www.cadviet.c...iles/mau1_2.dwg
  • 0

#33 namhai

namhai

    biết vẽ rectang

  • Members
  • PipPip
  • 81 posts
Danh tiếng: 18 (tm tạm)

Gửi vào 02 July 2009 - 04:20 PM

Bạn c thể Upload file Cad ln diễn đn ?

đy l file m e đ xo bằng thủ cng, bc xem c cch no gip e xo được cc đường đồng mức kh chịu đy khng nh :s_big:
http://www.cadviet.c..._TONG_THE_1.dwg
  • 0
Hy lm việc hết mnh rồi mọi điều tốt đẹp sẽ đến với bạn.....

#34 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 02 July 2009 - 04:23 PM

C mơn Bc Gia Bach nhiều, lisp lệnh swb chưa chạy đng em lắm v khi chọn đối tượng trong vng kn để copy ra ring th bản vẽ chnh của mnh bị ph nt ngay vng kn mnh chọn. Khng biết Bc c giải php no để khi chọn cc đối tượng trong 1 vng kn dng lệnh copy th bản vẽ chnh của mnh khng bị ph nt như khi dng lệnh SWB. Thank Bc nhiều.
Đy l file cad mẫu:
http://www.cadviet.c...iles/mau1_2.dwg

Đng l : đuợc voi đi Hai b Trưng .... Posted Image
  • 1

#35 namhai

namhai

    biết vẽ rectang

  • Members
  • PipPip
  • 81 posts
Danh tiếng: 18 (tm tạm)

Gửi vào 02 July 2009 - 04:56 PM

Trong file CAD của bạn, đuờng bao c cao độ Z=0, cc đuờng đồng mức c cao độ Z khc 0
-> Đuờng bao v đuờng đồng mức thực tế khng giao nhau (mặc d trn mặt bằng nhn thấy giao nhau).
Lisp chỉ chạy đuợc với cc đối tuợng c giao (cắt). :s_big:

e explode đường đồng mức v thấy vẫn xo được cc đối tượng c Z khc 0 m, nhưng chỉ xo được những đối tượng nằm trong curve chứ khng xo được cc đường giao với curve?
  • 0
Hy lm việc hết mnh rồi mọi điều tốt đẹp sẽ đến với bạn.....

#36 xuandao0708

xuandao0708

    biết lệnh scale

  • Members
  • PipPipPip
  • 140 posts
Danh tiếng: 9 (bnh thường)

Gửi vào 02 July 2009 - 05:49 PM

Hix, Bc GiaBach thng cảm, khng phải em được voi m đi b Trương đu. Tại em thấy lệnh Ewb n tương đối giống 1 lệnh trong Micro nn em nhờ Bc viết hộ thm 1 lệnh chọn đối tượng trong vng kn, nhưng khng ngờ sau khi chọn v copy ra th n ph nt bản vẽ. Monh Bc thng cảm, nếu c g sai st mong Bc bỏ qua cho em. Thank Bc nhiều.
  • 0

#37 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 03 July 2009 - 01:16 PM

Hix, Bc GiaBach thng cảm, khng phải em được voi m đi b Trương đu. Tại em thấy lệnh Ewb n tương đối giống 1 lệnh trong Micro nn em nhờ Bc viết hộ thm 1 lệnh chọn đối tượng trong vng kn, nhưng khng ngờ sau khi chọn v copy ra th n ph nt bản vẽ. Monh Bc thng cảm, nếu c g sai st mong Bc bỏ qua cho em. Thank Bc nhiều.

Cho xuandao0708
Bạn chạy thử Lisp Copy đối tuợng chọn theo đuờng bao.
Hy vọng đng bạn. :s_big: download here
  • 5

#38 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 03 July 2009 - 01:55 PM

e explode đường đồng mức v thấy vẫn xo được cc đối tượng c Z khc 0 m, nhưng chỉ xo được những đối tượng nằm trong curve chứ khng xo được cc đường giao với curve?

Cho namhai
Với cc đối tượng nằm trong v ngoi curve : Lisp lm việc bnh thuờng.
Với đối tượng c giao với curve trn mặt bằng nhưng nếu trong khng gian chng khng giao nhau (khng đồng phẳng) th Lisp khng xử l đuợc.
Bạn c thể dng Lisp ny để xa tất cả đối tượng nằm ngoi curve. (khng phn biệt c giao trn mặt bằng hay giao trong khng gian)
(defun C:EOB (  / en ss lst ssall bbox) ;EOB -> Erasre Out Boudary(vl-load-com)  (if (and (setq en (car(entsel "\n Chon duong bao : ")))           (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))    (progn      (setq bbox (ACET-ENT-GEOMEXTENTS en))      (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))      (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))      (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))      (command "_.Zoom" "0.95x")      (if (null etrim)(load "extrim.lsp"))      (etrim en (polar                  (car bbox)                  (angle (car bbox)(cadr bbox))                  (* (distance (car bbox)(cadr bbox)) 1.1)))      (if (and            (setq ss (ssget "_CP" lst))            (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))           )        (progn          (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))          (foreach e1 lst (ssdel e1 ssall))          (ACET-SS-ENTDEL ssall)          )        )      )    )  )

  • 2

#39 quanghuy181

quanghuy181

    biết vẽ line

  • Members
  • PipPip
  • 28 posts
Danh tiếng: 1 (bnh thường)

Gửi vào 03 July 2009 - 01:57 PM

Lệnh EBO
Command: eob

Chon duong bao : ; error: no function definition: ACET-ENT-GEOMEXTENTS

Command:
Command: EOB
Chon duong bao : ; error: no function definition: ACET-ENT-GEOMEXTENTS

Command:
Command: EOB
Chon duong bao : ; error: no function definition: ACET-ENT-GEOMEXTENTS

Đừng ni l em chưa ci bộ EXPRESS TOOL nha. Em ci rồi bc ạ.
  • 0

#40 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1,271 posts
Danh tiếng: 1326 (rất tốt)

Gửi vào 03 July 2009 - 02:50 PM

.....................
Chon duong bao : ; error: no function definition: ACET-ENT-GEOMEXTENTS
.............
Đừng ni l em chưa ci bộ EXPRESS TOOL nha. Em ci rồi bc ạ.

Cho quanghuy181
C lẽ thư viện EXPRESS TOOLS chưa đuợc active.
Bạn cần thực thi lệnh EXPRESSTOOLS để active thư viện EXPRESS TOOLS truớc khi sử dụng.
  • 1