[Yêu cầu] lisp xoá text !

[leejang 5]

Em muốn có 1 lisp xoá các text có điểm đặt cách nhau 1 đoạn nhỏ hơn giá trị mà người dùng nhập vào( ví dụ nhập vào là A thì giữa 3 text nằm cách nhau <A sẽ xóa đi 1 text còn lại các text sao cho khoảng cách giữa chúng >A ). ứng dụng để xoá bớt các text cao độ sát nhau trên bình đồ hoặc trắc ngang ! Mong được các bác giúp đỡ !

[ketxu 2.984]

Trên diễn đàn đã có đề cập đến vấn đề này rồi, bạn hãy nhìn ở mục Similar topic dưới bài viết của bạn

[leejang 5]

Trên diễn đàn đã có đề cập đến vấn đề này rồi, bạn hãy nhìn ở mục Similar topic dưới bài viết của bạn

Bác KETXU ạ ? Trên diễn đàn e đã tìm, nhưng mà cái yêu cầu lisp của e nó cấp cao hơn chứ ạ ? Nó tổng quát hơn, ở đây không phải là xoá text trùng nhau. Vì xoá text trùng nhau thì ta có thể dùng lệnh overkill. Ở đây là giữa 2 text cách nhau 1 khoảng nhỏ hơn giá trị nhập vào thì xoá đi 1 text. Sao cho các text còn lại ko có text nào nằm cách nhau 1 đoạn < giá trị nhập vào !

[duy782006 1.549]

Bác KETXU ạ ? Trên diễn đàn e đã tìm, nhưng mà cái yêu cầu lisp của e nó cấp cao hơn chứ ạ ? Nó tổng quát hơn, ở đây không phải là xoá text trùng nhau. Vì xoá text trùng nhau thì ta có thể dùng lệnh overkill. Ở đây là giữa 2 text cách nhau 1 khoảng nhỏ hơn giá trị nhập vào thì xoá đi 1 text. Sao cho các text còn lại ko có text nào nằm cách nhau 1 đoạn < giá trị nhập vào !

Chịu khó đọc cái chủ đề mà bạn cho là ko cao cấp đó sẻ thấy nó cao cấp rồi đó bạn.

[thanhduan2407 272]

Bác KETXU ạ ? Trên diễn đàn e đã tìm, nhưng mà cái yêu cầu lisp của e nó cấp cao hơn chứ ạ ? Nó tổng quát hơn, ở đây không phải là xoá text trùng nhau. Vì xoá text trùng nhau thì ta có thể dùng lệnh overkill. Ở đây là giữa 2 text cách nhau 1 khoảng nhỏ hơn giá trị nhập vào thì xoá đi 1 text. Sao cho các text còn lại ko có text nào nằm cách nhau 1 đoạn < giá trị nhập vào !

Bạn chưa xem hết mà đã khẳng định cao cấp hơn, phải chăng bạn lười đọc ??? . Cố gắng đọc hết để tìm hiểu cái mình tìm nhé. Bạn muốn lọc điểm chứ gì, nếu bạn muốn lọc điểm thì có nhiều phương pháp lắm. Bạn đã ngâm cái thằng Trimble Map chưa, nó cổ tí nhưng dùng hay ra phết.

http://www.4shared.com/file/Umx1dFtP/Trimble_Map.html

[leejang 5]

Bạn chưa xem hết mà đã khẳng định cao cấp hơn, phải chăng bạn lười đọc ??? . Cố gắng đọc hết để tìm hiểu cái mình tìm nhé. Bạn muốn lọc điểm chứ gì, nếu bạn muốn lọc điểm thì có nhiều phương pháp lắm. Bạn đã ngâm cái thằng Trimble Map chưa, nó cổ tí nhưng dùng hay ra phết.

http://www.4shared.com/file/Umx1dFtP/Trimble_Map.html

 

Hic. Các bác cứ mắng em. E tìm trên diễn đàn và có được cái Lisp XCDX đây: http://www.cadviet.com/upfiles/2/xu_ly_cao...dx_scc__ccc.rar

 

Nhưng khi chạy thì nó chẳng xóa được cái j cả mà báo lỗi. ko bit bác nào có kinh nghiệm thì chỉ giáo cách sử dụng cho em với. Và lisp không cho người dùng nhập khoảng cách tối thiểu giữa các text ?

 

 

Và lisp :

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=23110

(defun c:xoatext (/)

(command "_.undo" "be")

(setvar "cmdecho" 0)

(setq ss (ssget (list (cons 0 "TEXT"))))

(if (= kc nil)

(setq kc1 5)

(setq kc1 kc)

)

(setq kc (getreal (strcat "\nKhoang cach min: <" (rtos kc1) ">")))

(if (= kc nil)

(setq kc kc1)

)

(setq nhom (ssadd))

(setq i 0)

(repeat (sslength ss)

(setq tam (ssname ss 0))

(setq j 1)

(repeat (- (sslength ss) 1)

(if (/= (ssname ss j) nil)

(progn

(if (< (distance (cdr (assoc 10 (entget tam)))

(cdr (assoc 10 (entget (ssname ss j))))

)

kc

)

(progn

(setq nhom (ssadd (ssname ss j) nhom))

(setq ss (ssdel (ssname ss j) ss))

)

)

)

)

 

(setq j (+ j 1))

)

(if (/= tam nil)

(setq ss (ssdel tam ss))

)

(setq i (+ i 1))

)

(command "change" nhom "" "p" "c" "5" "")

(command "_.undo" "e")

(princ)

)

 

Khi chạy thì CAD báo lỗi :

Command: xoatext

 

Select objects: Specify opposite corner: 4 found

 

Select objects: error: bad argument type: numberp: #<SUBR @0396f35c KC>

 

Lisp: Ftext

 

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=23110&st=20

(defun c:FText (/ ent ent1 i lst newlayer ofset ss ss1 ss_tmp)

;|By Gia Bach 2010|;

(defun GetBound (ent ofs / ang elist ll lr tb tb1 tb2 ul ur)

(setq elist (entget ent)

ang (cdr (assoc 50 elist))

tb (textbox elist)

tb1 (car tb)

tb2 (cadr tb)

ll (polar (cdr (assoc 10 elist))

(+(angle '(0 0) tb1) ang) (DISTANCE '(0 0) tb1))

lr (polar ll ang (- (car tb2) (car tb1)))

ur (polar ll (+ ang (angle tb1 tb2)) (distance tb1 tb2))

ul (polar ll (+ ang (/ pi 2)) (- (cadr tb2) (cadr tb1))) )

(setq ang (angle ll lr) )

(setq ll (polar ll (- ang (* pi 0.75)) (sqrt (* (* ofs ofs) 2)))

lr (polar lr (- ang (/ pi 4)) (sqrt (* (* ofs ofs) 2)))

ur (polar ur (+ ang (/ pi 4)) (sqrt (* (* ofs ofs) 2)))

ul (polar ul (+ ang (* pi 0.75)) (sqrt (* (* ofs ofs) 2))) )

(list ll lr ur ul))

 

(command "_.undo" "be")

(setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd) )

(or *ofset (setq *ofset 0.5))

(initget 4)

(setq ofset (getreal (strcat "\nNhap khoang cach duong vien : <" (rtos *ofset) ">")))

(if (= ofset nil) (setq ofset *ofset) (setq *ofset ofset))

 

(while (> (sslength ss) 0)

(setq ent (ssname ss 0)

lst (GetBound ent ofset) )

(ssdel ent ss)

(if (setq ss_tmp (ssget "cp" lst (list(cons 0 "TEXT"))))

(progn

(setq i -1)

(while (setq ent1 (ssname ss_tmp (setq i (1+ i))))

(if (not (equal ent ent1))

(progn

(ssadd ent1 ss1)

(if (ssmemb ent1 ss) (ssdel ent1 ss)) ))) ) ) )

(if (> (sslength ss1) 0)

(progn

(setq newlayer "Text_Filter")

(if (not (tblsearch "layer" newlayer))

(command "-layer" "n" newlayer "c" 2 newlayer "") )

(command "change" ss1 "" "p" "la" newlayer "") ) )

(command "_.undo" "e")

(princ))

 

 

khi chạy thì không xóa được cái gì cả

[thanhduan2407 272]

Hic. Các bác cứ mắng em. E tìm trên diễn đàn và có được cái Lisp XCDX đây: http://www.cadviet.com/upfiles/2/xu_ly_cao...dx_scc__ccc.rar

 

Nhưng khi chạy thì nó chẳng xóa được cái j cả mà báo lỗi. ko bit bác nào có kinh nghiệm thì chỉ giáo cách sử dụng cho em với. Và lisp không cho người dùng nhập khoảng cách tối thiểu giữa các text ?

 

 

Và lisp :

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2311

 

 

khi chạy thì không xóa được cái gì cả

bạn dùng lisp này để lọc nhé. Vẫn là cái trong diễn đàn thôi. Bạn tìm hiểu kỹ nhé, mình đâu có mắng bạn đâu.

;; free lisp from cadviet.com
;;;;;;;;; Loc text theo khoang cach
;Filter Text
(defun c:FText (/ ent ent1 fil fil1 flag j kc newlayer pos ss ss1 str str1 ss_tmp tmp tmp1)
;|By Gia Bach 2010|;
(command "_.undo" "be")
(setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd))
(or kc1 (setq kc1 5))
(setq kc (getreal (strcat "\nNhap khoang cach : <" (rtos kc1) ">")))
(if (= kc nil) (setq kc kc1) (setq kc1 kc))
(while (> (sslength ss) 0)
(setq ent (ssname ss 0)
pos (cdr (assoc 10 (entget ent))) 
ss (ssdel ent ss)
ss_tmp ss
flag nil)
(setq j -1)
(while (setq ent1 (ssname ss_tmp (setq j (1+ j))))
(if (<= (distance pos (cdr (assoc 10 (entget ent1)))) kc)
(setq flag t
str1 (append (list (cdr (assoc 1 (entget ent1)))) str1)
ss1 (ssadd ent1 ss1)
ss (ssdel ent1 ss)) ) )
(if flag
(setq ss1 (ssadd ent ss1)
str1 (append (list(cdr (assoc 1 (entget ent)))) str1))
(setq str (append (list(cdr (assoc 1 (entget ent)))) str)) ) )
(if (> (sslength ss1) 0)
(progn
(setq newlayer (getstring t "\nNhap ten layer chua Text can filter :"))
(if (not (tblsearch "layer" newlayer))
(command "-layer" "n" newlayer"") ) 
(command "change" ss1 "" "p" "la" newlayer "")
(if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
(setq fil (open tmp "w") )
(foreach txt str
(write-line txt fil) )
(close fil)
(setq tmp1 (strcat (vl-filename-directory tmp) "\\"
(vl-filename-base tmp) "_filter"
(vl-filename-extension tmp))
fil1 (open tmp1 "w"))
(foreach txt str1
(write-line txt fil1) )
(close fil1) )) ))
(command "_.undo" "e")
(princ))




;;;;;;
;; free lisp from cadviet.com
;;;;;;;;; Loc text khong theo khoang cach
(defun c:FText0 (/ ent ent1 fil fil1 i j lst newlayer pos ss ss0 ss1 ss_tmp str str1 tmp tmp1)
 ;|By Gia Bach 2010|;
(defun MakeBound (ent / ang elist ll lr tb tb1 tb2 ul ur)
 (setq elist (entget ent)
ang   (cdr (assoc 50 elist))
tb    (textbox elist)
tb1   (car tb)
tb2   (cadr tb)
ll    (polar (cdr (assoc 10 elist))
	     (+(angle '(0 0) tb1) ang) (DISTANCE '(0 0) tb1))
lr    (polar ll ang (- (car tb2) (car tb1)))
ur    (polar ll (+ ang (angle tb1 tb2)) (distance tb1 tb2))
ul    (polar ll (+ ang (/ pi 2)) (- (cadr tb2) (cadr tb1)))    )
 (list ll lr ur ul))

 (command "_.undo" "be")
 (setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd) ss0 (ssadd))
 (while (> (sslength ss) 0)
   (setq ent (ssname ss 0)
  lst (MakeBound ent) )
   (ssdel ent ss)
   (if (setq ss_tmp (ssget "cp" lst (list(cons 0 "TEXT"))))
     (progn
(setq i -1)
(while (setq ent1 (ssname ss_tmp (setq i (1+ i))))
  (if (not (equal ent ent1))
    (progn
      (setq str1 (append (list (list (cdr (assoc 1 (entget ent1)))
				     (cdr (assoc 10 (entget ent1))))) str1))
      (ssadd ent1 ss1)
      (if (ssmemb ent1 ss) (ssdel ent1 ss))
      (if (ssmemb ent1 ss0) (ssdel ent1 ss0)))))	) )
   (if (not (ssmemb ent ss1)) (ssadd ent ss0))    )
 (setq j -1)
 (while (setq ent (ssname ss0 (setq j (1+ j))))
   (setq str (append (list (list (cdr (assoc 1 (entget ent)))
			  (cdr (assoc 10 (entget ent))))) str)) )
 (if (> (sslength ss1) 0)
   (progn
     (setq newlayer "CV");(getstring t "\nNhap ten layer chua Text can filter :"))
     (if (not (tblsearch "layer" newlayer))
(command "-layer" "n" newlayer "c" 2 newlayer "")	)         
     (command "change" ss1 "" "p" "la" newlayer "")
     (if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
  (setq fil (open tmp "w") )
  (foreach txt str
    (setq pos (cadr txt))
    (write-line (strcat (car txt) (chr 44) (rtos(car pos)) (chr 44) (rtos(cadr pos))(chr 44) 
                           (rtos(caddr pos)))fil)   )
  (close fil)
  (setq tmp1 (strcat (vl-filename-directory tmp) "\\"
		     (vl-filename-base tmp) "_filter"
		     (vl-filename-extension tmp))
	fil1 (open tmp1 "w"))
  (foreach txt str1
    (setq pos (cadr txt))
    (write-line (strcat (car txt) (chr 44) (rtos(car pos)) (chr 44) (rtos(cadr pos))(chr 44) 
                           (rtos(caddr pos))) fil1)   )
  (close fil1)  ))  ) )
 (command "_.undo" "e")
 (princ))

 

http://www.4shared.com/file/btx_Cjjr/Loc_text_theo_kcach_ftext_ftex.html

[ketxu 2.984]

 

Lisp: Ftext

 

 

khi chạy thì không xóa được cái gì cả

Giờ mới đọc bài này. Minh chưa chạy thử nhưng theo đoạn code thì rõ ràng bác gia_bach đã làm 1 việc là lọc các text đó sang 1 layer mới là Text_Filter, rồi có gì thì bạn kiểm tra và tự xử lý nó được mà. Nếu muốn xóa thì thay dòng (command "change" ss1 "" "p" "la" newlayer "") thành (command "erase" ss1 "")

Ngoài ra tham khảo 2 lisp bác thanhduan post