Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
61 replies to this topic

#61 nhatphong

nhatphong

    biết vẽ circle

  • Members
  • PipPip
  • 33 Bài viết
Điểm đánh giá: 4 (bình thường)

Đã gửi 20 December 2012 - 08:47 PM

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
  • 0

#62 Tep_Pi

Tep_Pi

    biết vẽ line

  • Members
  • PipPip
  • 26 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 22 March 2014 - 08:32 AM

Á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/...79#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 ® (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


  • 0