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

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

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

Đâ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    226

Đâ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.649

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

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

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

 

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

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

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


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

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


×