Chuyển đến nội dung
Diễn đàn CADViet
victor85

[Yêu cầu] Nhờ viết lisp tạo nhanh wipeout

Bởi victor85 , trong AutoLisp

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

binhtl88    0

binhtl88
Đã đăng

Quick code

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Lwpolyline duoc chon thanh cac Wipeout.
(defun C:HA1( / cmd entlst xoa)
(command "undo" "be")
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE")))))))
(initget "X K") (setq xoa (getkword "\n[Xoa/Khong xoa] pline cu <X>: "))
(if (= xoa "K") (setq xoa "N") (setq xoa "Y"))
(foreach ent entlst
 (setq lst (acet-geom-vertex-list ent))
 (cond
  ((= 1 (cdr (assoc 70 (entget ent))))
(command "wipeout" "p" ent xoa))
  ((and (= 0 (cdr (assoc 70 (entget ent)))) (equal (car lst) (last lst) 1E-8))
(entmod (subst (cons 70 1) (assoc 70 (entget ent)) (entget ent)))
(command "wipeout" "p" ent xoa))))
(setvar "cmdecho" cmd)
(command "undo" "end")
(princ))

P/S (17h15' ngày 05/4/2012): Hiệu chỉnh để wipeout được với cả Lwpolyline kín nhưng open.

Anh ơi nhưng dùng lệnh này như thế nào ạ? e load lisp xòn ko biết thế nào nữa

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

congzui    3

congzui
Đã đăng

Bạn tải lisp từ link này (anh Ketxu hợp tác với nước ngoài). Load. Dùng lệnh OB2WO. Nhưng không như ý tuyệt đối được.

http://xaydungit.vn/...79#post14880779

Doan Van Ha ơi, với yêu cầu file CAD link ở trên, Ha sử dụng lisp của Ketxu làm được không? Sao mình che không được. Nếu Ha làm được xin chỉ giáo nhé

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

Doan Van Ha    3.191

Doan Van Ha
Đã đăng

Tôi đã test rồi mới giới thiệu cho bạn chứ. Chỉ có 2 điều:

1). Cái đường trục nằm ngang, sau khi wipeout, bạn cần vẽ lại.

2). Phần đường cong: không che tuyệt đối. Lý do: khi wipeout người ta chỉ làm gần đúng bằng cách vi phân đường cong thành từng đoạn nhỏ.

  • Vote tăng 1

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

ketxu    2.984

ketxu
Đã đăng

Do bài toán của bạn dở chừng, thằng che thằng k che.

- Nếu chỉ cần kết quả mà k cần giữ nguyên gốc

+ Lisp : Rỗi thì mình có thể giúp bạn k che đường tim, còn tạm thời bạn cứ .... vẽ lại hoặc set top draw order cho nó ^^

+ Tay : extrim

 

- Nêú cần kết quả + gốc + thuận tiện :

Bạn nghiên cứu 3 chủ đề : Wipeout + Draw Order + Stretch Dynamic Block. Đảm bảo làm một lần sướng luôn :D

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

congzui    3

congzui
Đã đăng

Tôi đã test rồi mới giới thiệu cho bạn chứ. Chỉ có 2 điều:

1). Cái đường trục nằm ngang, sau khi wipeout, bạn cần vẽ lại.

2). Phần đường cong: không che tuyệt đối. Lý do: khi wipeout người ta chỉ làm gần đúng bằng cách vi phân đường cong thành từng đoạn nhỏ.

 

Mình vẫn không làm được

Các bước mình làm như sau:

Command: ob2wo

Select objects: Sau đó mình chọn đường polyline

Select objects: 1 found

Enter

Delete source objects: (yes/no): mình chọn yes hoặc no đều không nhìn thấy polyline này che polyline kia

Không biết cần chọn gì thêm không? Xin chỉ giáo

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

Doan Van Ha    3.191

Doan Van Ha
Đã đăng

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.

; error: bad function: #<SUBR @098d7b68 -lambda->

Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS
;http://xaydungit.vn/diendan/showthread.php?7784-Wipe-PLine-v%C3%A0-b%E1%BA%ADt-t%E1%BA%AFt-nhanh-Wipeout&p=14880779#post14880779
;----- Chuyen ss thanh cac Wipeout.
(defun c:ob2wo (/ ent lst nor ss)
 (vl-load-com)
 (if  (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))    
   (progn
     (vla-StartundoMark
   (vla-get-ActiveDocument (vlax-get-acad-object))
     )
       (initget "Yes No")      
       (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))      
     (foreach ent (ST:Ss->ListEnt ss)
       (setq lst (ent2ptlst ent))
       (setq nor (cdr (assoc 210 (entget ent))))    
       (makeWipeout lst nor)
       (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
     )
     (vla-EndundoMark
   (vla-get-ActiveDocument (vlax-get-acad-object))
     )
   )
 )
)
;----- Bat/Tat qua lai giua Wipeout va Pline
;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
 (cond
   ((and
       (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
       (ssget "x" '((0 . "WIPEOUT,INSERT")))
   )
   (entmod    (subst    (cons 70 (boole 6 (cdr (assoc 70 elst)) 1))    (assoc 70 elst)    elst))
   (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
       (vla-update obj)
   )
 )
   (T (princ "\nHave no wipeout object !"))
   )
 (princ)
)
;----- Chuyen cac Wipeout thanh Pline
;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
 (if (setq ss (ssget '((0 . "WIPEOUT"))))
 (progn
   (initget "Yes No")      
   (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))    
   (foreach wo    (ST:Ss->ListEnt ss)    
     (setq
       elst (entget wo)
       norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
       pts 	(wipeout2plst wo)
     )
     (entmake
   (append
     (list    '(0 . "LWPOLYLINE")
       '(100 . "AcDbEntity")
       '(100 . "AcDbPolyline")
       (cons 90 (length pts))
       (cons 38 (caddr (trans (car pts) 0 norm)))
       '(70 . 1)
       (cons 210 norm)
     )
     (mapcar '(lambda (pt)
        	(setq pt (trans pt 0 norm))
        	(list 10 (car pt) (cadr pt))
      	)
         pts
     )
   )
     )
     (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)      
 )))  
)
;;==================SUB ROUTINES==================;;
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
 (setq    elst (entget wo)
   u    (cdr (assoc 11 elst))
   v    (cdr (assoc 12 elst))
   mat  (list u (mapcar '- v) '(0. 0. 1.))
 )
 (mapcar
   '(lambda (p)
  	(mapcar '+
      	(mxv (trp mat) p)
      	(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
      	(cdr (assoc 10 elst))
  	)
	)
   (cdr
     (mapcar 'cdr
         (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
     )
   )
 )
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
 (apply 'mapcar (cons 'list m))
)
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
 (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
 (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
   (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
   (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
 )
)
;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
 ((lambda (l)
	(if (/= 0 l)
  	(mapcar (function (lambda (x) (/ x l))) v)
	)
  )
   (distance '(0 0 0) v)
 )
)


;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS

(defun ent2ptlst (ent / obj dist n lst p_lst prec)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
 )
 (cond
   ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
	(setq dist    (/ (vlax-curve-getDistAtParam
        	obj
        	(vlax-curve-getEndParam obj)
      	)
      	50
       )
  	n    0
	)
	(repeat 50
  	(setq
	lst
     (cons
       (trans
         (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
         0
         (vlax-get obj 'Normal)
       )
       lst
     )
  	)
	)
   )
   (T
	(setq p_lst (vl-remove-if-not
      	'(lambda (x)
             (or (= (car x) 10)
             (= (car x) 42)
             )
           )
      	(entget ent)
    	)
	)
	(while p_lst
  	(setq
	lst
     (cons
       (append (cdr (assoc 10 p_lst))
           (list (cdr (assoc 38 (entget ent))))
       )
       lst
     )
  	)
  	(if (/= 0 (cdadr p_lst))
	(progn
  	(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
    	dist (/ (- (if    (cdaddr p_lst)
                 (vlax-curve-getDistAtPoint
               obj
               (trans (cdaddr p_lst) ent 0)
                 )
                 (vlax-curve-getDistAtParam
               obj
               (vlax-curve-getEndParam obj)
                 )
               )
               (vlax-curve-getDistAtPoint
                 obj
                 (trans (cdar p_lst) ent 0)
               )
        	)
        	prec
             )
    	n    0
  	)
  	(repeat (1- prec)
    	(setq
      	lst (cons
        	(trans
          	(vlax-curve-getPointAtDist
        	obj
        	(+ (vlax-curve-getDistAtPoint
                 obj
                 (trans (cdar p_lst) ent 0)
               )
               (* dist (setq n (1+ n)))
        	)
          	)
          	0
          	ent
        	)
        	lst
      	)
    	)
  	)
	)
  	)
  	(setq p_lst (cddr p_lst))
	)
   )
 )
 lst
)


;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object

(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
 (if (not (member "acwipeout.arx" (arx)))
   (arxload "acwipeout.arx")
 )
 (setq    dxf10 (list (apply 'min (mapcar 'car pt_lst))
           (apply 'min (mapcar 'cadr pt_lst))
           (caddar pt_lst)
         )
 )
 (setq
   max_dist
	(float
  	(apply 'max
         (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
  	)
	)
 )
 (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
 (setq
   dxf14 (mapcar
       '(lambda (p)
      	(mapcar '/
          	(mapcar '- p cen)
          	(list max_dist (- max_dist) 1.0)
      	)
    	)
       pt_lst
     )
 )
 (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
 (entmake (append (list '(0 . "WIPEOUT")
        	'(100 . "AcDbEntity")
        	'(100 . "AcDbWipeout")
        	'(90 . 0)
        	(cons 10 (trans dxf10 nor 0))
        	(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
        	(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
        	'(13 1.0 1.0 0.0)
        	'(70 . 7)
        	'(280 . 1)
        	'(71 . 2)
        	(cons 91 (length dxf14))
      	)
      	(mapcar '(lambda (p) (cons 14 p)) dxf14)
  	)
 )
)

(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons e l))
 )  
)

  • Vote tăng 1

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

ketxu    2.984

ketxu
Đã đăng

Lỗi tag PHP của 4room VBB tự động xóa bỏ dấu ' đằng trước chữ (lambda ... ở hàm gần cuối nên sinh ra vậy. Ketxu đã sửa tag thành code cho an toàn (lần sau dùng funtion cho lành ^^)

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

nhatphong    7

nhatphong
Đã đăng

Lisp chuyển các Wipeout thành các Lwpolyline.

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Wipeout duoc chon thanh cac Lwpolyline.
(defun C:HA2( / cmd ped entlst ss ent)
(command "undo" "be")
(setq cmd (getvar "cmdecho") ped (getvar "peditaccept"))
(setvar "cmdecho" 0) (setvar "peditaccept" 0)
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "WIPEOUT")))))))
(foreach ent1 entlst
 (setq ss (ssadd) ent (entlast))
 (command "explode" ent1)
 (while (setq ent (entnext ent))
  (setq ss (ssadd ent ss)))
 (command "pedit" "m" ss "" "y" "j" 0 ""))
(setvar "cmdecho" cmd) (setvar "peditaccept" ped) (command "undo" "end")
(princ))

bạn ơi sao lúc bỏ Wipeout thành Pline thì được sao vẫn còn 1 điểm chấm nhỉ? xóa luôn trong lisp được kg!thank bạn

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

Tep_Pi    4

Tep_Pi
Đã đăng

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.
; error: bad function: #<SUBR @098d7b68 -lambda->
Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS
;http://xaydungit.vn/diendan/showthread.php?7784-Wipe-PLine-v%C3%A0-b%E1%BA%ADt-t%E1%BA%AFt-nhanh-Wipeout&p=14880779#post14880779
;----- Chuyen ss thanh cac Wipeout.
(defun c:ob2wo (/ ent lst nor ss)
  (vl-load-com)
  (if  (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))    
    (progn
      (vla-StartundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
        (initget "Yes No")      
        (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))      
      (foreach ent (ST:Ss->ListEnt ss)
        (setq lst (ent2ptlst ent))
        (setq nor (cdr (assoc 210 (entget ent))))    
        (makeWipeout lst nor)
        (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
      )
      (vla-EndundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
    )
  )
)
;----- Bat/Tat qua lai giua Wipeout va Pline
;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
  (cond
    ((and
        (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
        (ssget "x" '((0 . "WIPEOUT,INSERT")))
    )
    (entmod    (subst    (cons 70 (boole 6 (cdr (assoc 70 elst)) 1))    (assoc 70 elst)    elst))
    (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
        (vla-update obj)
    )
  )
    (T (princ "\nHave no wipeout object !"))
    )
  (princ)
)
;----- Chuyen cac Wipeout thanh Pline
;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
  (if (setq ss (ssget '((0 . "WIPEOUT"))))
  (progn
    (initget "Yes No")      
    (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))    
    (foreach wo    (ST:Ss->ListEnt ss)    
      (setq
        elst (entget wo)
        norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
        pts 	(wipeout2plst wo)
      )
      (entmake
    (append
      (list    '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (cons 90 (length pts))
        (cons 38 (caddr (trans (car pts) 0 norm)))
        '(70 . 1)
        (cons 210 norm)
      )
      (mapcar '(lambda (pt)
         	(setq pt (trans pt 0 norm))
         	(list 10 (car pt) (cadr pt))
       	)
          pts
      )
    )
      )
      (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)      
  )))  
)
;;==================SUB ROUTINES==================;;
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
  (setq    elst (entget wo)
    u    (cdr (assoc 11 elst))
    v    (cdr (assoc 12 elst))
    mat  (list u (mapcar '- v) '(0. 0. 1.))
  )
  (mapcar
    '(lambda (p)
   	(mapcar '+
       	(mxv (trp mat) p)
       	(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
       	(cdr (assoc 10 elst))
   	)
 	)
    (cdr
      (mapcar 'cdr
          (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
      )
    )
  )
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
  (apply 'mapcar (cons 'list m))
)
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
  (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
    (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
    (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)
;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
  ((lambda (l)
 	(if (/= 0 l)
   	(mapcar (function (lambda (x) (/ x l))) v)
 	)
   )
    (distance '(0 0 0) v)
  )
)
 
 
;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS
 
(defun ent2ptlst (ent / obj dist n lst p_lst prec)
  (vl-load-com)
  (if (= (type ent) 'ENAME)
    (setq obj (vlax-ename->vla-object ent))
  )
  (cond
    ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
 	(setq dist    (/ (vlax-curve-getDistAtParam
         	obj
         	(vlax-curve-getEndParam obj)
       	)
       	50
        )
   	n    0
 	)
 	(repeat 50
   	(setq
 	lst
      (cons
        (trans
          (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
          0
          (vlax-get obj 'Normal)
        )
        lst
      )
   	)
 	)
    )
    (T
 	(setq p_lst (vl-remove-if-not
       	'(lambda (x)
              (or (= (car x) 10)
              (= (car x) 42)
              )
            )
       	(entget ent)
     	)
 	)
 	(while p_lst
   	(setq
 	lst
      (cons
        (append (cdr (assoc 10 p_lst))
            (list (cdr (assoc 38 (entget ent))))
        )
        lst
      )
   	)
   	(if (/= 0 (cdadr p_lst))
 	(progn
   	(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
     	dist (/ (- (if    (cdaddr p_lst)
                  (vlax-curve-getDistAtPoint
                obj
                (trans (cdaddr p_lst) ent 0)
                  )
                  (vlax-curve-getDistAtParam
                obj
                (vlax-curve-getEndParam obj)
                  )
                )
                (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
         	)
         	prec
              )
     	n    0
   	)
   	(repeat (1- prec)
     	(setq
       	lst (cons
         	(trans
           	(vlax-curve-getPointAtDist
         	obj
         	(+ (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
                (* dist (setq n (1+ n)))
         	)
           	)
           	0
           	ent
         	)
         	lst
       	)
     	)
   	)
 	)
   	)
   	(setq p_lst (cddr p_lst))
 	)
    )
  )
  lst
)
 
 
;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object
 
(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
  (if (not (member "acwipeout.arx" (arx)))
    (arxload "acwipeout.arx")
  )
  (setq    dxf10 (list (apply 'min (mapcar 'car pt_lst))
            (apply 'min (mapcar 'cadr pt_lst))
            (caddar pt_lst)
          )
  )
  (setq
    max_dist
 	(float
   	(apply 'max
          (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
   	)
 	)
  )
  (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
  (setq
    dxf14 (mapcar
        '(lambda (p)
       	(mapcar '/
           	(mapcar '- p cen)
           	(list max_dist (- max_dist) 1.0)
       	)
     	)
        pt_lst
      )
  )
  (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
  (entmake (append (list '(0 . "WIPEOUT")
         	'(100 . "AcDbEntity")
         	'(100 . "AcDbWipeout")
         	'(90 . 0)
         	(cons 10 (trans dxf10 nor 0))
         	(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
         	(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
         	'(13 1.0 1.0 0.0)
         	'(70 . 7)
         	'(280 . 1)
         	'(71 . 2)
         	(cons 91 (length dxf14))
       	)
       	(mapcar '(lambda (p) (cons 14 p)) dxf14)
   	)
  )
)
 
(defun ST:Ss->ListEnt (ss / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
    (setq l (cons e l))
  )  
)

thank bác.e đã thử wipeout vật thể có chứa arc và ok.

à, nhân tiện cho em hỏi có bác nào có lisp tự động vẽ viền bo ngoài của 1 vật thể ko, ví dụ e có 1 block có hình dạng phức tạp nhưng chỉ muốn tạo viền bo ngoài của vật thể đó để sau đó dùng wipeot cho block đó nổi lên trên các đối tượng khác

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

ThànhChung    0

ThànhChung
Đã đăng
On 11/10/2012 at 4:17 PM, Doan Van Ha said:

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.

; error: bad function: #<SUBR @098d7b68 -lambda->

Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

  


;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS
;http://xaydungit.vn/diendan/showthread.php?7784-Wipe-PLine-v%C3%A0-b%E1%BA%ADt-t%E1%BA%AFt-nhanh-Wipeout&p=14880779#post14880779
;----- Chuyen ss thanh cac Wipeout.
(defun c:ob2wo (/ ent lst nor ss)
 (vl-load-com)
 (if  (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))    
   (progn
     (vla-StartundoMark
   (vla-get-ActiveDocument (vlax-get-acad-object))
     )
       (initget "Yes No")      
       (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))      
     (foreach ent (ST:Ss->ListEnt ss)
       (setq lst (ent2ptlst ent))
       (setq nor (cdr (assoc 210 (entget ent))))    
       (makeWipeout lst nor)
       (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
     )
     (vla-EndundoMark
   (vla-get-ActiveDocument (vlax-get-acad-object))
     )
   )
 )
)
;----- Bat/Tat qua lai giua Wipeout va Pline
;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
 (cond
   ((and
       (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
       (ssget "x" '((0 . "WIPEOUT,INSERT")))
   )
   (entmod    (subst    (cons 70 (boole 6 (cdr (assoc 70 elst)) 1))    (assoc 70 elst)    elst))
   (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
       (vla-update obj)
   )
 )
   (T (princ "\nHave no wipeout object !"))
   )
 (princ)
)
;----- Chuyen cac Wipeout thanh Pline
;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
 (if (setq ss (ssget '((0 . "WIPEOUT"))))
 (progn
   (initget "Yes No")      
   (setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))    
   (foreach wo    (ST:Ss->ListEnt ss)    
     (setq
       elst (entget wo)
       norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
       pts 	(wipeout2plst wo)
     )
     (entmake
   (append
     (list    '(0 . "LWPOLYLINE")
       '(100 . "AcDbEntity")
       '(100 . "AcDbPolyline")
       (cons 90 (length pts))
       (cons 38 (caddr (trans (car pts) 0 norm)))
       '(70 . 1)
       (cons 210 norm)
     )
     (mapcar '(lambda (pt)
        	(setq pt (trans pt 0 norm))
        	(list 10 (car pt) (cadr pt))
      	)
         pts
     )
   )
     )
     (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)      
 )))  
)
;;==================SUB ROUTINES==================;;
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
 (setq    elst (entget wo)
   u    (cdr (assoc 11 elst))
   v    (cdr (assoc 12 elst))
   mat  (list u (mapcar '- v) '(0. 0. 1.))
 )
 (mapcar
   '(lambda (p)
  	(mapcar '+
      	(mxv (trp mat) p)
      	(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
      	(cdr (assoc 10 elst))
  	)
	)
   (cdr
     (mapcar 'cdr
         (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
     )
   )
 )
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
 (apply 'mapcar (cons 'list m))
)
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
 (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
 (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
   (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
   (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
 )
)
;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
 ((lambda (l)
	(if (/= 0 l)
  	(mapcar (function (lambda (x) (/ x l))) v)
	)
  )
   (distance '(0 0 0) v)
 )
)


;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS

(defun ent2ptlst (ent / obj dist n lst p_lst prec)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
 )
 (cond
   ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
	(setq dist    (/ (vlax-curve-getDistAtParam
        	obj
        	(vlax-curve-getEndParam obj)
      	)
      	50
       )
  	n    0
	)
	(repeat 50
  	(setq
	lst
     (cons
       (trans
         (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
         0
         (vlax-get obj 'Normal)
       )
       lst
     )
  	)
	)
   )
   (T
	(setq p_lst (vl-remove-if-not
      	'(lambda (x)
             (or (= (car x) 10)
             (= (car x) 42)
             )
           )
      	(entget ent)
    	)
	)
	(while p_lst
  	(setq
	lst
     (cons
       (append (cdr (assoc 10 p_lst))
           (list (cdr (assoc 38 (entget ent))))
       )
       lst
     )
  	)
  	(if (/= 0 (cdadr p_lst))
	(progn
  	(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
    	dist (/ (- (if    (cdaddr p_lst)
                 (vlax-curve-getDistAtPoint
               obj
               (trans (cdaddr p_lst) ent 0)
                 )
                 (vlax-curve-getDistAtParam
               obj
               (vlax-curve-getEndParam obj)
                 )
               )
               (vlax-curve-getDistAtPoint
                 obj
                 (trans (cdar p_lst) ent 0)
               )
        	)
        	prec
             )
    	n    0
  	)
  	(repeat (1- prec)
    	(setq
      	lst (cons
        	(trans
          	(vlax-curve-getPointAtDist
        	obj
        	(+ (vlax-curve-getDistAtPoint
                 obj
                 (trans (cdar p_lst) ent 0)
               )
               (* dist (setq n (1+ n)))
        	)
          	)
          	0
          	ent
        	)
        	lst
      	)
    	)
  	)
	)
  	)
  	(setq p_lst (cddr p_lst))
	)
   )
 )
 lst
)


;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object

(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
 (if (not (member "acwipeout.arx" (arx)))
   (arxload "acwipeout.arx")
 )
 (setq    dxf10 (list (apply 'min (mapcar 'car pt_lst))
           (apply 'min (mapcar 'cadr pt_lst))
           (caddar pt_lst)
         )
 )
 (setq
   max_dist
	(float
  	(apply 'max
         (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
  	)
	)
 )
 (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
 (setq
   dxf14 (mapcar
       '(lambda (p)
      	(mapcar '/
          	(mapcar '- p cen)
          	(list max_dist (- max_dist) 1.0)
      	)
    	)
       pt_lst
     )
 )
 (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
 (entmake (append (list '(0 . "WIPEOUT")
        	'(100 . "AcDbEntity")
        	'(100 . "AcDbWipeout")
        	'(90 . 0)
        	(cons 10 (trans dxf10 nor 0))
        	(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
        	(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
        	'(13 1.0 1.0 0.0)
        	'(70 . 7)
        	'(280 . 1)
        	'(71 . 2)
        	(cons 91 (length dxf14))
      	)
      	(mapcar '(lambda (p) (cons 14 p)) dxf14)
  	)
 )
)

(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons e l))
 )  
)
 

 

bác ơi lisp wipeout này em dùng được trên cad 2010 nhưng lên cad 2018 lại ko dùng được
cho em hỏi làm sao để dùng được trên cad 2018 vậy

load lisp rồi nhưng dùng ko có tác dụng bác ạ
lisp em đính kèm đó bác

ko dùng được trên cad 2018 quả thật đáng tiếc 

ob2wo_w1_wof_w2_wo2pl_w3.lsp

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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Về Đầu Trang AutoLisp
×