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

[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))
  )  
)  

[Tot77 508]

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

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

[Tot77 508]

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.

[gia_bach 1558]

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")

)

[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 :(

[Tot77 508]

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

[various 9]

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

Cảm ơn bác. Working :D