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

[nhờ chỉnh sửa] lisp xóa text trong 1 miền kín

Bởi huunhantvxdts , trong AutoLisp

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

huunhantvxdts    195

huunhantvxdts
Đã đăng

Đây là lisp tôi có chỉnh sửa lại đôi chút nhưng có vấn đề là chỉ xóa được các text trong miền kín nhìn thấy trên màn hình còn những text khác cũng nằm trong miên kín nhưng không thấy trên màn hình thì không xóa được mong mọi người giúp đỡ

đây là lisp

(defun c:xtpl ()
(setq dt  (ssget '((0 . "LWPOLYLINE"))))
(setq n (sslength dt) i 0)
(while (< i n)
(setq dt1 (ssname dt i))
(setq SS (ssget "wp" (acet-geom-vertex-list dt1)  (list (cons 0 "text"))))
(command ".erase" ss "")
(setq i (+ i 1))
)
(setq sdt (sslength ss))
)

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

thanhduan2407    272

thanhduan2407
Đã đăng

Đây là lisp tôi có chỉnh sửa lại đôi chút nhưng có vấn đề là chỉ xóa được các text trong miền kín nhìn thấy trên màn hình còn những text khác cũng nằm trong miên kín nhưng không thấy trên màn hình thì không xóa được mong mọi người giúp đỡ

đây là lisp

(defun c:xtpl ()
(setq dt  (ssget '((0 . "LWPOLYLINE"))))
(setq n (sslength dt) i 0)
(while (< i n)
(setq dt1 (ssname dt i))
(setq SS (ssget "wp" (acet-geom-vertex-list dt1)  (list (cons 0 "text"))))
(command ".erase" ss "")
(setq i (+ i 1))
)
(setq sdt (sslength ss))
)

 

Mình tặng bạn lisp có tính năng xóa text trong vùng kín chỉ cần 1 pick Point. Hy vọng bạn hài lòng

(defun C:xt (/  p ss Tong ptLst cur L)
(setvar "hpgaptol" 50.0)
(command "_.undo" "_begin")
(setq  p (getpoint "\nPick vao vung can tinh: "))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ss  (entlast))
  (setq ptLst	(GetPtLst (setq cur  (vlax-ename->vla-object  ss))))
  (setq ssInside (ssget "_WP" ptLst '((-4 . "<OR")  (0 . "TEXT")  (-4 . "OR>"))))
  (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
	(entdel itm)
  )
(command "_.undo" "_end")
(princ)
)

(defun getbound(p /)
(setq ent (entlast))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ent1 (entlast))
(cond
 	((eq ent ent1) nil)
 	(t ent1)
)
 )
(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
 (defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
  	(not (equal (car lst) (last lst) 1e-6)))
 	(append lst (list (car lst)))
 	lst)
 )
 (or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
 (setq typ (vlax-get obj 'ObjectName))
 (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
 	(setq param 0)
 	(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
  	ptlst (cons pt ptlst)
  	param (+ (/ (* pi 2) 72) param)))
 	(reverse ptlst))
(progn
 	(setq param (vlax-curve-getStartParam obj)
	endparam (vlax-curve-getEndParam obj)
	anginc (* pi (/ 7.5 180.0)))
 	(setq tparam param)
 	(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
  (setq ptlst (cons pt ptlst)))
(if  (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
  (progn
	(setq delta (* 4 (atan blg))
inc (/ 1.0 (1+ (fix (/ delta anginc))))
             	arcparam (+ param inc))
	(while (< arcparam (1+ param))
  	(setq pt (vlax-curve-getPointAtParam obj arcparam)
               	ptlst (cons pt ptlst)
               	arcparam (+ inc arcparam)))))
(setq param (1+ param)))
 	(if (and (apply 'and ptlst)
   	(> (length ptlst) 1))
(ZClosed (reverse ptlst)))))
 )

  • Vote tăng 2

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

Chủ topic : viết tiêu đề nên viết hoa chữ đầu như mọi ng đang làm

Xử lý lisp bạn : nếu thấy chỉ xử đc thằng nhìn thấy thì sao bạn k thử Zoom all hết, rồi làm, rồi zoom previous ? ( nếu là bạn viết). mình thấy đâu khó suy ra 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

phamthanhbinh    3.146

phamthanhbinh
Đã đăng
Mình tặng bạn lisp có tính năng xóa text trong vùng kín chỉ cần 1 pick Point. Hy vọng bạn hài lòng 
 (defun C:xt (/ p ss Tong ptLst cur L) (setvar "hpgaptol" 50.0) (command "_.undo" "_begin") (setq p (getpoint "\nPick vao vung can tinh: ")) (command ".boundary" "A" "B" "E" "I" "Y" "" p "") (setq ss (entlast)) (setq ptLst (GetPtLst (setq cur (vlax-ename->vla-object ss)))) (setq ssInside (ssget "_WP" ptLst '((-4 . "<OR") (0 . "TEXT") (-4 . "OR>")))) (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside))) (entdel itm) ) (command "_.undo" "_end") (princ) ) (defun getbound(p /) (setq ent (entlast)) (command ".boundary" "A" "B" "E" "I" "Y" "" p "") (setq ent1 (entlast)) (cond ((eq ent ent1) nil) (t ent1) ) ) (defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst) (defun ZClosed (lst) (if (and (vlax-curve-isClosed obj) (not (equal (car lst) (last lst) 1e-6))) (append lst (list (car lst))) lst) ) (or (eq (type obj) 'VLA-OBJECT) (setq obj (vlax-ename->vla-object obj))) (setq typ (vlax-get obj 'ObjectName)) (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse")) (progn (setq param 0) (while (< param (* pi 2)) (setq pt (vlax-curve-getPointAtParam obj param) ptlst (cons pt ptlst) param (+ (/ (* pi 2) 72) param))) (reverse ptlst)) (progn (setq param (vlax-curve-getStartParam obj) endparam (vlax-curve-getEndParam obj) anginc (* pi (/ 7.5 180.0))) (setq tparam param) (while (<= param endparam) (setq pt (vlax-curve-getPointAtParam obj param)) (if (not (equal pt (car ptlst) 1e-12)) (setq ptlst (cons pt ptlst))) (if (and (/= param endparam) (setq blg (abs (vlax-invoke obj 'GetBulge param))) (/= 0 blg)) (progn (setq delta (* 4 (atan blg)) inc (/ 1.0 (1+ (fix (/ delta anginc)))) arcparam (+ param inc)) (while (< arcparam (1+ param)) (setq pt (vlax-curve-getPointAtParam obj arcparam) ptlst (cons pt ptlst) arcparam (+ inc arcparam))))) (setq param (1+ param))) (if (and (apply 'and ptlst) (> (length ptlst) 1)) (ZClosed (reverse ptlst))))) )

Hề hề hề,

Hình như bác này không đọc kỹ yêu cầu của chủ thớt. Vấn đề mà chủ thớt gặp không khắc phục bằng lisp bác tặng được đâu. Lỗi là do hàm ssget chỉ chọn các đối tượng nhòm thấy được trên màn hình. Còn những em núp gió đâu đó thì nó bỏ qua luôn. Bởi vậy để xử lý vấn đề này chỉ cần sử dụng thêm hai dòng code là có thể ngon.

Dòng 1: (command "zoom" "e") đặt phía trước hàm ssget

Dòng 2: (command "zoom" "p") đặt phía sau hàm lặp while (hay foreach của bác) .

Bác và chủ thớt hãy kiểm tra lại xem nhé.

Hề hề hề,...

  • Vote tăng 2

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

Zuy782006    11

Zuy782006
Đã đăng

Hề hề hề,

Hình như bác này không đọc kỹ yêu cầu của chủ thớt. Vấn đề mà chủ thớt gặp không khắc phục bằng lisp bác tặng được đâu. Lỗi là do hàm ssget chỉ chọn các đối tượng nhòm thấy được trên màn hình. Còn những em núp gió đâu đó thì nó bỏ qua luôn. Bởi vậy để xử lý vấn đề này chỉ cần sử dụng thêm hai dòng code là có thể ngon.

Dòng 1: (command "zoom" "e") đặt phía trước hàm ssget

Dòng 2: (command "zoom" "p") đặt phía sau hàm lặp while (hay foreach của bác) .

Bác và chủ thớt hãy kiểm tra lại xem nhé.

Hề hề hề,...

Zoom e hoặc all hơi phiền chi bằng zoom Object các bác 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

huunhantvxdts    195

huunhantvxdts
Đã đăng

Chủ topic : viết tiêu đề nên viết hoa chữ đầu như mọi ng đang làm

Xử lý lisp bạn : nếu thấy chỉ xử đc thằng nhìn thấy thì sao bạn k thử Zoom all hết, rồi làm, rồi zoom previous ? ( nếu là bạn viết). mình thấy đâu khó suy ra nhỉ ^^

Rút kinh nghiệm lần sau, cám ơn 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

huunhantvxdts    195

huunhantvxdts
Đã đăng

 

Mình tặng bạn lisp có tính năng xóa text trong vùng kín chỉ cần 1 pick Point. Hy vọng bạn hài lòng

(defun C:xt (/  p ss Tong ptLst cur L)
(setvar "hpgaptol" 50.0)
(command "_.undo" "_begin")
(setq  p (getpoint "\nPick vao vung can tinh: "))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ss  (entlast))
  (setq ptLst	(GetPtLst (setq cur  (vlax-ename->vla-object  ss))))
  (setq ssInside (ssget "_WP" ptLst '((-4 . "<OR")  (0 . "TEXT")  (-4 . "OR>"))))
  (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
(entdel itm)
  )
(command "_.undo" "_end")
(princ)
)

(defun getbound(p /)
(setq ent (entlast))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ent1 (entlast))
(cond
 	((eq ent ent1) nil)
 	(t ent1)
)
 )
(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
 (defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
  	(not (equal (car lst) (last lst) 1e-6)))
 	(append lst (list (car lst)))
 	lst)
 )
 (or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
 (setq typ (vlax-get obj 'ObjectName))
 (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
 	(setq param 0)
 	(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
  	ptlst (cons pt ptlst)
  	param (+ (/ (* pi 2) 72) param)))
 	(reverse ptlst))
(progn
 	(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
 	(setq tparam param)
 	(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
  (setq ptlst (cons pt ptlst)))
(if  (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
  (progn
(setq delta (* 4 (atan blg))
inc (/ 1.0 (1+ (fix (/ delta anginc))))
             	arcparam (+ param inc))
(while (< arcparam (1+ param))
  	(setq pt (vlax-curve-getPointAtParam obj arcparam)
               	ptlst (cons pt ptlst)
               	arcparam (+ inc arcparam)))))
(setq param (1+ param)))
 	(if (and (apply 'and ptlst)
   	(> (length ptlst) 1))
(ZClosed (reverse ptlst)))))
 )

Không xử lý được những Text ko nhìn thấy

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

Zuy782006    11

Zuy782006
Đã đăng

Bạn có thể viết cho mình zoom Object được không??

cám ơn bạn

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from [url="http://www.cadviet.com/forum/index.php?showtopic=68051&pid=221519&st=0entry221519"]http://www.cadviet.com/forum/index.php?showtopic=68051&pid=221519&st=0entry221519[/url]
(defun c:xtpl ()
(setq dt  (ssget '((0 . "LWPOLYLINE"))))
(setq n (sslength dt) i 0)
(while (< i n)
(setq dt1 (ssname dt i))
(command ".zoom" "o" dt1 "")
(setq SS (ssget "wp" (acet-geom-vertex-list dt1)  (list (cons 0 "text"))))
(command ".erase" ss "")
(command ".zoom" "p")
(setq i (+ i 1))
)
(setq sdt (sslength ss))
)

  • Vote tăng 2

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

phamthanhbinh    3.146

phamthanhbinh
Đã đăng

Bạn có thể viết cho mình zoom Object được không??

cám ơn bạn

Hề hề hề,

Zoom object chỉ có từ CAD đời cao hơn 2004. Với CAD2004 trở xuống chỉ có zoom extents và zoom all mới giải quyết được.

  • Vote tăng 2

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

huunhantvxdts    195

huunhantvxdts
Đã đăng 


;; free lisp from cadviet.com
;;; this lisp was downloaded from [url="http://www.cadviet.com/forum/index.php?showtopic=68051&pid=221519&st=0entry221519"]http://www.cadviet.com/forum/index.php?showtopic=68051&pid=221519&st=0entry221519[/url]
(defun c:xtpl ()
(setq dt  (ssget '((0 . "LWPOLYLINE"))))
(setq n (sslength dt) i 0)
(while (< i n)
(setq dt1 (ssname dt i))
(command ".zoom" "o" dt1 "")
(setq SS (ssget "wp" (acet-geom-vertex-list dt1)  (list (cons 0 "text"))))
(command ".erase" ss "")
(command ".zoom" "p")
(setq i (+ i 1))
)
(setq sdt (sslength ss))
)

Cám ơn bạn nhiều lắm

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

huunhantvxdts    195

huunhantvxdts
Đã đăng

Hề hề hề,

Zoom object chỉ có từ CAD đời cao hơn 2004. Với CAD2004 trở xuống chỉ có zoom extents và zoom all mới giải quyết được.

Không sao cả bây giờ mình đang dùng CAD2008 mà

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
×