Đế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

#1 victor85

victor85

    biết lệnh stretch

  • Members
  • PipPipPip
  • 169 Bài viết
Điểm đánh giá: 10 (tàm tạm)

Đã gửi 04 April 2012 - 03:56 PM

Các bác viết dùm em lisp tạo nhanh wipeout từ nhiều đối tượng polyline cùng lúc.
Đầu vào: chọn các đối tượng polyline.
Hỏi chọn:Xóa hay không xóa các polyline đã chọn.
Đầu ra: tạo các wipeout từ các polyline ban đầu.
Em xin cảm ơn các bác trước ạ. :)
  • 0

#2 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 04 April 2012 - 04:18 PM

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.
  • 4

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#3 victor85

victor85

    biết lệnh stretch

  • Members
  • PipPipPip
  • 169 Bài viết
Điểm đánh giá: 10 (tàm tạm)

Đã gửi 04 April 2012 - 04:47 PM

Em cảm ơn bác Doan Van Ha nhiều nhé. Mà lúc nãy quên mất, không nhờ viết luôn cả cái thao tác ngược lại phức tạp hơn biến từ wipeout thành poly line với. Bác xem có giúp đc e luôn ko với?
  • 0

#4 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 04 April 2012 - 05:01 PM

Em cảm ơn bác Doan Van Ha nhiều nhé. Mà lúc nãy quên mất, không nhờ viết luôn cả cái thao tác ngược lại phức tạp hơn biến từ wipeout thành poly line với. Bác xem có giúp đc e luôn ko với?

Được Voi đòi... Hai Bà Trưng!
Được! Nếu đến tối chưa ai viết thì tôi viết giùm bạn. OK?
  • 2

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#5 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 04 April 2012 - 05:09 PM

Đặt gạch hóng phát. đang cần, chờ bác Hà ra là múc luôn :ph34r:
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#6 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 04 April 2012 - 07:54 PM

Em cảm ơn bác Doan Van Ha nhiều nhé. Mà lúc nãy quên mất, không nhờ viết luôn cả cái thao tác ngược lại phức tạp hơn biến từ wipeout thành poly line với. Bác xem có giúp đc e luôn ko với?

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

  • 7

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#7 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 04 April 2012 - 10:06 PM

Code cũ của gile, ketxu sửa thêm 1 chút :

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

  • 5

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#8 Detailing

Detailing

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 667 Bài viết
Điểm đánh giá: 278 (khá)

Đã gửi 04 April 2012 - 11:07 PM

Mình nghĩ Block và Hatch cũng là 2 thứ cần dùng wipeout.
ko biết các bạn có ý tưởng gì ko?
p/s: nếu ko dùng command và (vl-commandf) thì tốt.
Thanks!
  • 0

Ideas don't matter, execution does!

1908412_308002392716743_8165279281236341


#9 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 05 April 2012 - 12:30 AM

Có hàm make wipeout rồi mà bạn. vấn đề chỉ là bạn xử lý hatch và bock của bạn như thế nào thôi
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#10 Detailing

Detailing

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 667 Bài viết
Điểm đánh giá: 278 (khá)

Đã gửi 05 April 2012 - 08:06 AM

Có hàm make wipeout rồi mà bạn. vấn đề chỉ là bạn xử lý hatch và bock của bạn như thế nào thôi

Thì đó mới là thứ để bàn,
làm sao lấy dc boundary của Block và Hatch?
còn polyline thì cứ việc chọn xong: (command "wipeout" .........)
  • 0

Ideas don't matter, execution does!

1908412_308002392716743_8165279281236341


#11 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 05 April 2012 - 08:20 AM

Thì đó mới là thứ để bàn,
làm sao lấy dc boundary của Block và Hatch?
còn polyline thì cứ việc chọn xong: (command "wipeout" .........)

Boundary của Hatch thì khả dĩ, nhưng boundary của block thì mơ hồ quá. Vì block chứa text, line, point... May ra định nghĩa boundary của Block theo kiểu lấy rectang có ll và ur thì khả dĩ nhỉ?
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#12 Detailing

Detailing

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 667 Bài viết
Điểm đánh giá: 278 (khá)

Đã gửi 05 April 2012 - 08:26 AM

Boundary của Hatch thì khả dĩ, nhưng boundary của block thì mơ hồ quá. Vì block chứa text, line, point... May ra định nghĩa boundary của Block theo kiểu lấy rectang có ll và ur thì khả dĩ nhỉ?

Đối với Block chỉ cần che những hình kín trong block thôi, line, arc rời ko cần che (ko che dc)
Bạn có cách nào lấy boundary của Hatch mà ko dùng command + commandf thì có thể cho mình chút gợi ý ko?
p/s: về block mình có thử 1 cái ở đây: http://www.cadviet.c...showtopic=62902
Hatch thì đang thử nhưng chưa work dc tất cả
  • 0

Ideas don't matter, execution does!

1908412_308002392716743_8165279281236341


#13 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 05 April 2012 - 08:46 AM

Đối với Block chỉ cần che những hình kín trong block thôi, line, arc rời ko cần che (ko che dc)
Bạn có cách nào lấy boundary của Hatch mà ko dùng command + commandf thì có thể cho mình chút gợi ý ko?
p/s: về block mình có thử 1 cái ở đây: http://www.cadviet.c...showtopic=62902
Hatch thì đang thử nhưng chưa work dc tất cả

Tôi nói khả dĩ với Hatch, nghĩa là hy vọng có thể lấy boundary của nó được, chứ chưa thử.
Cái này của Jimmy Bergmark hình như lấy được. Tôi mới test sơ qua thì thấy OK, chưa nghiên cứu kỹ. Detailing nghiên cứu xem nhé. Lệnh là HB.

;----- 3). Recreates hatch boundary by selecting a hatch
;;; HATCHB.LSP ver 2.5
;;; Known problem with some elipses and splines
;;; By Jimmy Bergmark. Copyright (C) 1997-2008 JTB World, All Rights Reserved. Website: www.jtbworld.com. E-mail: info@jtbworld.com
;;; 2000-02-12 - First release
;;; 2000-03-27 - Counterclockwise arcs and ellipses fixed
;;; Objects created joined to lwpolyline if possible
;;; Error-handling, undo of command
;;; Can handle PLINETYPE = 0,1,2
;;; 2000-03-30 - Integrating hatchb and hatchb14
;;; Selection of many hatches
;;; Splines supported if closed.
;;; 2001-04-02 - Fixed bug with entmake of line with no Z for r14
;;; 2001-07-31 - Removed an irritating semicolon to enable polylines to be created.
;;; 2001-10-04 - Changed mail and homepage so it's easy to find when new versions comes up.
;;; 2003-02-06 - Minor fix
;;; 2003-02-17 - Area returned if no islands is found since it's not consistant
;;; 2003-05-19 - Fix to take PEDITACCEPT variable used in AutoCAD 2004 into account
;;; 2004-11-05 - Minor bugs fixed
;;; 2006-03-18 - Nothing changed from 2.1 other that it's been confirmed to work with AutoCAD 2007
;;; 2006-05-13 - Create the boundary on the same layer as the hatch using the hbl command and
;;; on current layer/color/linetype using the hb or hatchb command
;;; 2007-02-08 - Fixed a bug with the hbl command
;;; 2008-02-29 - Support for hatches in non WCS thanks to xiaocai
;;; Tested on AutoCAD r14, 2000, 2000i, 2002, 2004, 2005, 2006, 2007, 2008, 2009
;;; should be working on older versions too.
(defun c:hb () (hatchb nil)) ; this line can be commented out if there is an existing command called hb
(defun c:hbl () (hatchb T)) ; this line can be commented out if there is an existing command called hbl
(defun c:hatchb () (hatchb nil))
(defun hatchb (hl / es blay ed1 ed2 loops1 bptf part
et noe plist ic bul nr ang1 ang2 obj *ModelSpace* *PaperSpace*
space cw errexit undox olderr oldcmdecho ss1 lastent en1 en2 ss lwp
list->variantArray 3dPoint->2dPoint A2k ent i ss2
knot-list controlpoint-list kn cn pos xv bot area hst noarea
)
(setq A2k (>= (substr (getvar "ACADVER") 1 2) "15"))
(if A2k
(progn
(defun list->variantArray (ptsList / arraySpace sArray)
(setq arraySpace
(vlax-make-safearray
vlax-vbdouble
(cons 0 (- (length ptsList) 1))))
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray))
(defun areaOfObject (en / curve area)
(if en
(if A2k
(progn
(setq curve (vlax-ename->vla-object en))
(if
(vl-catch-all-error-p
(setq
area
(vl-catch-all-apply 'vlax-curve-getArea (list curve))))
nil
area))
(progn
(command "._area" "_O" en)
(getvar "area")))))))
(if A2k
(defun 3dPoint->2dPoint (3dpt)
(list (float (car 3dpt)) (float (cadr 3dpt)))))
(defun errexit (s)
(princ "\nError: ")
(princ s)
(restore))
(defun undox ()
(command "._ucs" "_p")
(command "._undo" "_E")
(setvar "cmdecho" oldcmdecho)
(setq *error* olderr)
(princ))
(setq olderr *error*
restore undox
*error* errexit)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "._UNDO" "_BE")
(if A2k (progn
(vl-load-com)
(setq *ModelSpace* (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object)))
*PaperSpace* (vla-get-PaperSpace
(vla-get-ActiveDocument (vlax-get-acad-object))))))
; Remove for testing purpose
; (setq A2k nil)
(if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)
(progn
(setq i 0)
(setq area 0)
(setq bMoreLoops nil)
(while (setq ent (ssname ss2 i))
(setq noarea nil)
(setq ed1 (entget ent))
(setq layer (cdr (assoc 8 ed1)))
; (if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0))) (princ "\nHatch not in WCS!")) ;modified by xiaocai
; (setq xv (cdr (assoc 210 ed1))) ;modified by xiaocai
(command "._ucs" "_w")
(setq loops1 (cdr (assoc 91 ed1))) ; number of boundary paths (loops)
(if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))
(setq space *ModelSpace*)
(setq space *PaperSpace*))
(repeat loops1
(setq ed1 (member (assoc 92 ed1) ed1))
(setq bptf (cdr (car ed1))) ; boundary path type flag
(setq ic (cdr (assoc 73 ed1))) ; is closed
(setq noe (cdr (assoc 93 ed1))) ; number of edges
(setq bot (cdr (assoc 92 ed1))) ; boundary type
(setq hst (cdr (assoc 75 ed1))) ; hatch style
(setq ed1 (member (assoc 72 ed1) ed1))
(setq bul (cdr (car ed1))) ; bulge
(setq plist nil)
(setq blist nil)
(cond
((> (boole 1 bptf 2) 0) ; polyline
(repeat noe
(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
(setq plist (append plist (list (trans (cdr (assoc 10 ed1)) ent 0) ))) ;;add trans by xiaocai
(setq blist (append blist
(if (> bul 0)
(list (cdr (assoc 42 ed1)))
nil))))
(if A2k (progn
(setq polypoints
(apply 'append
(mapcar '3dPoint->2dPoint plist)))
(setq VLADataPts (list->variantArray polypoints))
(setq obj (vla-addLightweightPolyline space VLADataPts))
(setq nr 0)
(repeat (length blist)
(if (/= (nth nr blist) 0)
(vla-setBulge obj nr (nth nr blist)))
(setq nr (1+ nr)))
(if (= ic 1)
(vla-put-closed obj T))
(if hl (vla-put-layer obj layer)))
(progn
(setq ne (append (list '(0 . "POLYLINE")) (list (cons 66 1))))
(if (= ic 1) (setq ne (append ne (list (cons 70 1)))))
(if hl (setq ne (append ne (list (cons 8 layer)))))
(entmake ne)
(setq nr 0)
(repeat (length plist)
(if (= bul 0)
(entmake (list (cons 0 "VERTEX")
(cons 10 (trans (nth nr plist) ent 0) );;add trans by xiaocai
))
(entmake (list (cons 0 "VERTEX")
(cons 10 (trans (nth nr plist) ent 0) );;add trans by xiaocai
(cons 42 (nth nr blist)))))
(setq nr (1+ nr)))
(entmake '((0 . "SEQEND"))))))
(t ; not polyline
(setq lastent (entlast))
(setq lwp T)
(repeat noe
(setq et (cdr (assoc 72 ed1)))
(cond
((= et 1) ; line
(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
(if A2k
(progn
(setq obj (vla-AddLine
space
(vlax-3d-point (trans (cdr (assoc 10 ed1)) ent 0) ) ;;add trans by xiaocai
(vlax-3d-point (trans (cdr (assoc 11 ed1)) ent 0) ) ;;add trans by xiaocai
))
(if hl (vla-put-layer obj layer)))
(progn
(setq ne (append (list (cons 0 "LINE"))
(list (list 10 (car (trans (cdr (assoc 10 ed1)) ent 0) ) (cadr (trans (cdr (assoc 10 ed1)) ent 0)) 0)) ;;add trans by xiaocai
(list (list 11 (car (trans (cdr (assoc 11 ed1)) ent 0) ) (cadr (trans (cdr (assoc 11 ed1)) ent 0)) 0)) ;;add trans by xiaocai
;(cons 210 xv)
))
(if hl (setq ne (append ne (list (cons 8 layer)))))
(entmake ne)))
(setq ed1 (cddr ed1)))
((= et 2) ; circular arc
(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
(setq ang1 (cdr (assoc 50 ed1)))
(setq ang2 (cdr (assoc 51 ed1)))
(setq cw (cdr (assoc 73 ed1)))
(if (and (equal ang1 0 0.00001) (equal ang2 6.28319 0.00001))
(progn
(if A2k
(progn
(setq obj (vla-AddCircle
space
(vlax-3d-point (trans (cdr (assoc 10 ed1)) ent 0) )
(cdr (assoc 40 ed1))))
(if hl (vla-put-layer obj layer)))
(progn
(setq ne (append
(list (cons 0 "CIRCLE"))
(list (cons 8 layer))
(list (cons 10 (trans (cdr (assoc 10 ed1)) ent 0)));;;add trans by xiaocai
(list (assoc 40 ed1))))
(if hl (setq ne (append ne (list (cons 8 layer)))))
(entmake ne)))
(setq lwp nil))
(if A2k
(progn
(setq obj (vla-AddArc
space
(vlax-3d-point (trans (cdr (assoc 10 ed1)) ent 0) );;;add trans by xiaocai
(cdr (assoc 40 ed1))
(if (= cw 0)
(- 0 ang2)
ang1)
(if (= cw 0)
(- 0 ang1)
ang2)))
(if hl (vla-put-layer obj layer)))
(progn
(setq ne (append (list (cons 0 "ARC"))
(list (cons 10 (trans (cdr (assoc 10 ed1)) ent 0) ));;add trans by xiaocai
(list (assoc 40 ed1))
(list (cons 50
(if (= cw 0)
(- 0 ang2)
ang1)))
(list (cons 51
(if (= cw 0)
(- 0 ang1)
ang2)))))
(if hl (setq ne (append ne (list (cons 8 layer)))))
(entmake ne))))
(setq ed1 (cddddr ed1)))
((= et 3) ; elliptic arc
(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
(setq ang1 (cdr (assoc 50 ed1)))
(setq ang2 (cdr (assoc 51 ed1)))
(setq cw (cdr (assoc 73 ed1)))
(if A2k (progn
(setq obj (vla-AddEllipse
space
(vlax-3d-point (trans (cdr (assoc 10 ed1)) ent 0) )
(vlax-3d-point (trans (cdr (assoc 11 ed1)) ent 0) );;add trans by xiaocai
(cdr (assoc 40 ed1))))
(vla-put-startangle obj (if (= cw 0) (- 0 ang2) ang1))
(vla-put-endangle obj (if (= cw 0) (- 0 ang1) ang2))
(if hl (vla-put-layer obj layer)))
(progn
(princ "\nElliptic arc not supported!")
(setq noarea T)))
(setq lwp nil))
((= et 4) ; spline
(setq ed1 (member (assoc 94 (cdr ed1)) ed1))
(setq knot-list nil)
(setq controlpoint-list nil)
(setq kn (cdr (assoc 95 ed1)))
(setq cn (cdr (assoc 96 ed1)))
(setq pos (vl-position (assoc 40 ed1) ed1))
(repeat kn
(setq knot-list (cons (cons 40 (cdr (nth pos ed1))) knot-list))
(setq pos (1+ pos)))
(setq pos (vl-position (assoc 10 ed1) ed1))
(repeat cn
(setq controlpoint-list (cons (cons 10 (trans (cdr (nth pos ed1)) ent 0) ) controlpoint-list));;add trans by xiaocai
(setq pos (1+ pos)))
(setq knot-list (reverse knot-list))
(setq controlpoint-list (reverse controlpoint-list))
(setq ne (append
(list '(0 . "SPLINE"))
(list (cons 100 "AcDbEntity"))
(list (cons 100 "AcDbSpline"))
(list (cons 70 (+ 1 8 (* 2 (cdr (assoc 74 ed1))) (* 4 (cdr (assoc 73 ed1))))))
(list (cons 71 (cdr (assoc 94 ed1))))
(list (cons 72 kn))
(list (cons 73 cn))
knot-list
controlpoint-list))
(if hl (setq ne (append ne (cons 8 layer))))
(entmake ne)
(setq ed1 (member (assoc 10 ed1) ed1))
(setq lwp nil))
) ; end cond
) ; end repeat noe
(if lwp (progn
(setq en1 (entnext lastent))
(setq ss (ssadd))
(ssadd en1 ss)
(while (setq en2 (entnext en1))
(ssadd en2 ss)
(setq en1 en2))
(if (= (getvar "peditaccept") 1)
(command "_.pedit" (entlast) "_J" ss "" "")
(command "_.pedit" (entlast) "_Y" "_J" ss "" ""))))) ; end t
) ; end cond
; Tries to get the area on islands but it's not clear how to know if an island is filled or not
; and if it should be substracted or added to the total area.
; (if (or (= bot 0) (= (boole 1 bot 1) 1)) (setq area (+ area (areaOfObject (entlast)))))
; (if (and (/= hst 1) (/= bot 0) (= (boole 1 bot 1) 0)) (setq area (- area (areaOfObject (entlast)))))
; (princ "\n") (princ bot) (princ "\n") (princ hst) (princ "\n")
; (princ (areaOfObject (entlast)))
) ; end repeat loops1
(if (and (= noarea nil) (= loops1 1)) (setq area (+ area (areaOfObject (entlast)))) (setq bMoreLoops T))
(setq i (1+ i)))))
(if (and area (not bMoreLoops)) (progn
(princ "\nTotal Area = ")
(princ area)))
(restore)
(princ))
Còn thằng block, để nghiên cứu xem sao, nhưng chắc khó.
  • 3

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#14 bach1212

bach1212

    biết lệnh trim

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

Đã gửi 05 April 2012 - 08:50 AM

File đính kèm: http://www.cadviet.c...304_wipeout.rar
Cho e hỏi trong bản vẽ kèm theo trên: dùng lisp HA của bác Doan Van Ha thì bỏ sót 1 đường polyline (đường này dùng lệnh PL vẽ mới) không được chọn. Dùng xong lisp HA chỉ tạo được 3 đường wipeout? Nguyên nhân do đâu ah?
Dùng HA2, sau khi biến đường wipeout về polyline, rồi dùng lại HA thì lisp HA ko nhận đường polyline vừa chuyển đổi đó được? Còn dùng WO2PL thì vẫn oki.....
Có thể bổ sung cho chọn đối tượng là đường tròn không ah hay nói chung là tất cả các đối tượng miễn sao là kín ah? Cái này cũng hay dùng đến các bác ah!!! :D
  • 0

Một môn tập luyện mang lại vô vàn lợi ích sức khỏe cho mọi người, nhiều bệnh tật nan y đều được chữa khỏi, hoàn toàn miễn phí. Hiệu quả chữa khỏi bệnh tật của nó lên đến hơn 90%.
Tài liệu tại đây: http://phapluan.org/

Rất vui được làm quen với mọi người trên facebook:
https://www.facebook...67946371&type=1

 

 


#15 hockhiem

hockhiem

    biết lệnh erase

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

Đã gửi 05 April 2012 - 08:58 AM

Quick code


;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Tao nhieu Wipeout cung luc.
(defun C:HA( / 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
(command "wipeout" "p" ent xoa))
(setvar "cmdecho" cmd)
(command "undo" "end")
(princ))



Mình test thử lisp này thì bị như này là sao:

Select objects:
[Xoa/Khong xoa] pline cu <X>: x
The polyline must be closed and made up of only line segments.
Unknown command "Y". Press F1 for help.


Lisp này chỉ cần click vào đường PL thì nó sẽ tự động biến thành wipeout có thể xóa pl cũ hoặc không à? còn đối với đối tượng không phải PL thì sao? đường tròn chẳng hạn?
  • 0

#16 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 05 April 2012 - 09:20 AM

File đính kèm: http://www.cadviet.c...304_wipeout.rar
Cho e hỏi trong bản vẽ kèm theo trên: dùng lisp HA của bác Doan Van Ha thì bỏ sót 1 đường polyline (đường này dùng lệnh PL vẽ mới) không được chọn. Dùng xong lisp HA chỉ tạo được 3 đường wipeout? Nguyên nhân do đâu ah?
Dùng HA2, sau khi biến đường wipeout về polyline, rồi dùng lại HA thì lisp HA ko nhận đường polyline vừa chuyển đổi đó được? Còn dùng WO2PL thì vẫn oki.....
Có thể bổ sung cho chọn đối tượng là đường tròn không ah hay nói chung là tất cả các đối tượng miễn sao là kín ah? Cái này cũng hay dùng đến các bác ah!!! :D

Bản chất của lệnh wipeout nguyên thuỷ chỉ tạo được wipeout cho polyline đóng và có các cạnh là các line (không chấp nhận arc). Trong bản vẽ của bạn chứa arc.
  • 1

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#17 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 05 April 2012 - 09:29 AM

Mình test thử lisp này thì bị như này là sao:
Lisp này chỉ cần click vào đường PL thì nó sẽ tự động biến thành wipeout có thể xóa pl cũ hoặc không à? còn đối với đối tượng không phải PL thì sao? đường tròn chẳng hạn?

1). Muốn xoá Pline cũ hay không là tuỳ bạn. Đây là y/c của chủ topic.
2). Y/c của chủ topic là wipeout các pline, vì vậy mà không có đường tròn hay elip...
3). Bản chất nguyên thuỷ của lệnh wipeout không wipeout được với đường tròn. Muốn làm được thì xem điều 4.
4). Bạn Ketxu đã có lisp để wipeout các đường tròn, bạn search xem.
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#18 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 05 April 2012 - 09:52 AM

Thì đó mới là thứ để bàn,
làm sao lấy dc boundary của Block và Hatch?
còn polyline thì cứ việc chọn xong: (command "wipeout" .........)

Hề hề hê,
Mình có ý hơi chuối để tạo wipeout cho block như sau:
1/- Duyệt qua các đối tượng con của block, nếu thằng nào là polyiline kín thì tạo wipeout theo thằng đó sử dụng lisp của bác DoanvanHa.
2/- Nếu không có thằng polyline kín nào thì tạo polyline kín từ các diểm trả về của hàm (acet-ent-geomextents blename) rồi tạo wipeout.
do hơi lu bu nên chưa có thời gian kiểm chứng ý đồ này, nếu có gì sai sót mong các bác đừng chấp trách.
Hề hề hề,...
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#19 victor85

victor85

    biết lệnh stretch

  • Members
  • PipPipPip
  • 169 Bài viết
Điểm đánh giá: 10 (tàm tạm)

Đã gửi 05 April 2012 - 11:15 AM

Cảm ơn tất cả các bác nhé! Hí hí, ko ngờ topic mình lập đông khách quá. Chúc cadviet phát triển hơn nữa!
  • 0

#20 hockhiem

hockhiem

    biết lệnh erase

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

Đã gửi 05 April 2012 - 11:19 AM

1). Muốn xoá Pline cũ hay không là tuỳ bạn. Đây là y/c của chủ topic.
2). Y/c của chủ topic là wipeout các pline, vì vậy mà không có đường tròn hay elip...
3). Bản chất nguyên thuỷ của lệnh wipeout không wipeout được với đường tròn. Muốn làm được thì xem điều 4.
4). Bạn Ketxu đã có lisp để wipeout các đường tròn, bạn search xem.


Mình dùng thử lisp của bạn mà không được đối với các pline nối tiếp và khép kín, nhưng dùng được với rec là sao nhỉ? nó không có tác dụng đối với pline khép kín à???
  • 1