Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
various

[ Hỏi ] Lỗi Lisp Vẽ Wipeout Không Có Tác Dụng Trong Acad2016

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

various    9

Em sử dụng lisp có code như thế này. Ở Acad2010 vẫn bình thường, sang 2016 thì không có tác dụng nữa. Mong mọi người giúp đỡ

;;; 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à-bật-tắt-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))
  )  
)  

111657_untitled_1.gif

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
various    9

Do thiếu file acwipeout.arx, ban thử kiếm file đó ở 2010 rồi chép qua 2016 xem sao.

 

Em tìm trên mạng mà không có. :( Bác có thể upload lên hộ em được không ạ?

 

// Em search trên mạng thì hình như LSP này chưa working với cad2016 

 

in autocad 2016 appears this message “error: ARXLOAD failed”, have someone tested or modify the lisp?

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
Tot77    501

Bạn nói dùng vơi cad2010 vẫn bình thường, chứng tỏ là trong thư mục của 2010 đã có file đó rồi, cần gì kiếm trên mạng làm chi.

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

Từ Cad2013, arx này đã tích hợp vào "nhân" nên ko cần load nữa.

Chỉ cần tìm và xóa dòng dưới đây là chạy được.

(if (not (member "acwipeout.arx" (arx)))

(arxload "acwipeout.arx")

)

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
various    9

Từ Cad2013, arx này đã tích hợp vào "nhân" nên ko cần load nữa.

Chỉ cần tìm và xóa dòng dưới đây là chạy được.

(if (not (member "acwipeout.arx" (arx)))

(arxload "acwipeout.arx")

)

Vẫn bị " nil " bác gia_bach ơi :(

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
Tot77    501

Sửa lại và test trên AC2015 ok.

 

(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)))
   )
  )
 )
 
 (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)
 )
 
 (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) 
 ))) 
 )
 
 (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) )))
 )
 
 (defun trp (m) (apply 'mapcar (cons 'list m)))
 (defun mxv (m v)  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m))
 (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)))
  )
 )
 
 (defun vunit (v)
  ((lambda (l) (if (/= 0 l) (mapcar (function (lambda (x) (/ x l))) v) ) )
   (distance '(0 0 0) v)
  )
 )
 
 (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
)
  (defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
 (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")
(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) '(281 . 50) '(282 . 50) '(283 . 0)
'(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))
 ) 
 ) 

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

Đăng nhập để thực hiện theo  

×