Viết giúp Lisp xoá text trong khoảng nhất định

Tháng 8 18, 2010

Trong các bản vẽ,nhiều khi các text ( Thường gặp trong trắc địa,bản đồ)hay khi tôi chuyển các bản đồ tỷ lệ lớn thành bản đồ tỷ lệ nhỏ các điểm text dày đặc trên bản vẽ.Như vậy ta phải làm công tác thủ công mất nhiều thời gian để xoá các điểm thừa này. Vậy tôi muốn có 1 lisp xoá các text nằm gần nhau theo 1 khoảng các nhất định ví dụ 5m,5,5 m...nghĩa là 1 giá trị do ngưòi sử dụng yêu cầu.

1. Yêu cầu của tôi là lọc bỏ các điểm gần nhau chuyển sang layer khác ,các điểm giử lại nguyên layer đang có text này.

2.Xuất ra 2 file: 1 file chứa cá text đã loại sang layer khác,1 file các text còn lại sử dụng trên bản vẽ.

Mong được sự quan tâm của các bạn.

Vậy bài toán như sau:

Mở 1 bản vẽ chức text

Người dùng nhập 1 trị số nhất định:...

Lọc các text trong giá trị đó sang layer khác.

Xuât ra 2 file do người dùng yêu cầu.

Nếu có sử dung được hộp thoại thì rất tốt.

Xin cảm ơn

Tháng 8 18, 2010

Bạn thử xài đoạn lisp nay xem. Các text gần nhau sẽ chuyển sang màu xanh và bạn chọn lệnh ssx để lọc và xóa đối tượng

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

Tháng 8 18, 2010

Cơm ơn bạn,dù mới giải quyết 1 phần bài của mình ,xong đó là điều quan trong nhất .

Xin cảm ơn.

Nếu ở Hà nội,mời bạn đi uống bia luôn.

Ngô Đông Phương 0988529640

Tháng 8 18, 2010

Bạn thử xài đoạn lisp nay xem. Các text gần nhau sẽ chuyển sang màu xanh và bạn chọn lệnh ssx để lọc và xóa đối tượng

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

Chưa đạt yêu cầu vì một số điểm gần nhau mà vẫn chưa bị xoá.

Tháng 8 18, 2010

Trong các bản vẽ,nhiều khi các text ( Thường gặp trong trắc địa,bản đồ)hay khi tôi chuyển các bản đồ tỷ lệ lớn thành bản đồ tỷ lệ nhỏ các điểm text dày đặc trên bản vẽ.Như vậy ta phải làm công tác thủ công mất nhiều thời gian để xoá các điểm thừa này. Vậy tôi muốn có 1 lisp xoá các text nằm gần nhau theo 1 khoảng các nhất định ví dụ 5m,5,5 m...nghĩa là 1 giá trị do ngưòi sử dụng yêu cầu.
1. Yêu cầu của tôi là lọc bỏ các điểm gần nhau chuyển sang layer khác ,các điểm giử lại nguyên layer đang có text này.

2.Xuất ra 2 file: 1 file chứa cá text đã loại sang layer khác,1 file các text còn lại sử dụng trên bản vẽ.

Mong được sự quan tâm của các bạn.

Vậy bài toán như sau:

Mở 1 bản vẽ chức text

Người dùng nhập 1 trị số nhất định:...

Lọc các text trong giá trị đó sang layer khác.

Xuât ra 2 file do người dùng yêu cầu.

Nếu có sử dung được hộp thoại thì rất tốt.

Xin cảm ơn

Mình thì cũng mới học Lisp nhưng mình có phần mềm này làm được tương đối nhiều việc cho Trắc Địa chúng mình.

Quan điểm của mình là chia sẻ niềm vui và kinh nghiệm với mọi người. Ai có gì hay thì hãy post cho mọi ngừoi dùng nha.

http://www.4shared.com/file/lZicztaX/ReWriteDXF.html

Phần mềm viết bằng ngôn ngữ VB và bạn phải có 1 file .xyh hoặc file .dxf R12

Sau khi open bản vẽ dxf lên bạn chọn filter đó. Trong đó có rất nhiều cái hay.

Từ file .xyh có thể xuất sang cad một cách nhanh chóng và ngược lại

Chúc bạn thành công.

Tháng 8 18, 2010

Lisp đó mình thử nghiệm đúng như bạn nói chưa được 100 mới giải quyết được 80 % .

Song đó cũng là 1 hướng tôt rôi.

Để đóng góp thành sản phẩm cho bạn bè ,phải chỉnh sửa,làm được như mình yêu cầu.

Phần mềm bạn thanhduan gửi có thể rất hay,song mình chua biêt sử dụng.

Bạn có thể gửi hướng dẫn cho mình đến ndbngo@yahoo.com được không.

Nhưng mình vẫn thích làm trực tiếp trên cad .

Xin cảm ơn.

Mong làm quen với các bạn

Ngô Đông Phương -0988529640

Tháng 8 18, 2010

Lisp đó mình thử nghiệm đúng như bạn nói chưa được 100 mới giải quyết được 80 % .
Song đó cũng là 1 hướng tôt rôi.

Để đóng góp thành sản phẩm cho bạn bè ,phải chỉnh sửa,làm được như mình yêu cầu.

Phần mềm bạn thanhduan gửi có thể rất hay,song mình chua biêt sử dụng.

Bạn costheer gửi hướng dẫn cho mình đến ndbngo@yahoo.com được không.

Nhưng mình vẫn thích làm trực tiếp trên cad .

Xin cảm ơn.

Mong làm quen với các bạn

Ngô Đông Phương -0988529640

Rất đơn giản. Bạn dùng lệnh filter (lệnh " Fi ") để chọn ra các text cần lọc. Sau đó bạn paste sang một bản cad khác và save dưới đuôi .dxf ở dạng R12

Bạn mở phần mềm của mình ra và chọn file => chọn Open và chọn đến file dxf bạn vừa lưu. Bạn vào Tools => Filter và chọn mắt lưới cần lọc (đó chính là khoảng cách bạn cần lọc). Sau đó bạn save as sang file tên khác có đuôi dxf. Bạn thử mở bản vẽ đó lên xem kết quả nha. Chúc bạn thành công.

Tháng 8 19, 2010

Đoạn lisp này bạn có thể sử dụng trong bản vẽ nhiều lần

Khi bạn chạy command: xoatext được 80% rồi

Xóa text xong

Chạy lại command : xoatext lần 2... bạn sẽ xóa được 20% còn lại ==>100% thành công

Còn làm như yêu cầu 1+2 của bạn thì đối với Autolisp cũng rất dễ thôi

Nhưng điều này tốn thời gian nên mình sẽ pm trong dịp tới.

Tháng 8 19, 2010

Đúng vậy,phải sửa đoạn lisp đó thành 4 lệnh liên tục ,chuyển sang layer khác lưu lại thì giải quyết xong nhưng vẫn bất tiện. Bạn có thể cho thêm vòng lặp vào chương trình được không để khi không còn điều kiện thỏa mãn nữa thì dừng( hoặc số lần do người dùng muốn.

Nhưng cũng rất cảm ơn bạn về đoạn lips đó.

Bạn sửa dần di.Mình sẽ đề xuất hộp thoại để chương trình thân thiện và chuyên nghiệp hơn

Có thể cho mình thông tin về bạn được không.

Xin cảm ơn.

Cảm ơn Duy đã quan tâm nhé.

bạn Thanhduan có thể gửi cho minh 1 đọan video chạy và số liêu chạy đươjc không .Mình muốn test chương trình của bạn nhưng chưa được

Ngô Đông Phương 0988529640

Tháng 8 19, 2010

Đoạn lisp này bạn có thể sử dụng trong bản vẽ nhiều lần
Khi bạn chạy command: xoatext được 80% rồi

Xóa text xong

Chạy lại command : xoatext lần 2... bạn sẽ xóa được 20% còn lại ==>100% thành công

Còn làm như yêu cầu 1+2 của bạn thì đối với Autolisp cũng rất dễ thôi

Nhưng điều này tốn thời gian nên mình sẽ pm trong dịp tới.

Bạn nên dùng trích dẫn để biết rằng mình đang trả lời ai.

Bạn nói sai rồi, kể cả bạn chạy lại lệnh n lần cũng vẫn thế thôi, mình đã xem cấu trúc file lisp của bạn và nếu chạy chương trình thì cũng cao nhất 80%.

Không phải mình nói bạn lập trình không tốt nhưng với cách thức giải bài toán trên, lisp không thể là 100% được bạn à.

Mong rằng bạn sẽ cho ra sản phẩm hoàn thiện, và tất nhiên, nếu bạn tạo ra được thì tên tuổi của bạn sẽ được lưu lại trên lisp, nếu lỡ mai này mình có ý tưởng hay đối với lisp của bạn thì chắc rằng mình sẽ communicate với bạn. Chúc bạn luôn vui vẻ và có nhiều đóng góp cho cadviet

Tháng 8 19, 2010

Bạn nên dùng trích dẫn để biết rằng mình đang trả lời ai.
Bạn nói sai rồi, kể cả bạn chạy lại lệnh n lần cũng vẫn thế thôi, mình đã xem cấu trúc file lisp của bạn và nếu chạy chương trình thì cũng cao nhất 80%.

Không phải mình nói bạn lập trình không tốt nhưng với cách thức giải bài toán trên, lisp không thể là 100% được bạn à.

Mong rằng bạn sẽ cho ra sản phẩm hoàn thiện, và tất nhiên, nếu bạn tạo ra được thì tên tuổi của bạn sẽ được lưu lại trên lisp, nếu lỡ mai này mình có ý tưởng hay đối với lisp của bạn thì chắc rằng mình sẽ communicate với bạn. Chúc bạn luôn vui vẻ và có nhiều đóng góp cho cadviet

Mình đã thử khi xong lần 1 phải xóa toàn bộ đối tượng mầu 5. sau tiếp tục như thế 4 lần thì tốt ,chứ nếu o xóa thì chạy 10000000 lần kết qảu vẫn không đạt.

Cảm ơn.

Nếu có thể gửi minh video chạy chương trình và số liệu .Mình muốn thử chương trình của bạn.

Tháng 8 19, 2010

..........
1. Yêu cầu của tôi là lọc bỏ các điểm gần nhau chuyển sang layer khác ,các điểm giử lại nguyên layer đang có text này.

2.Xuất ra 2 file: 1 file chứa cá text đã loại sang layer khác,1 file các text còn lại sử dụng trên bản vẽ.

........

Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2 file (Txt hoặc CSV)

Cách sử dụng :

gõ lệnh : Ftext (Filter Text)

- chọn Text

- nhập k/cách

- nhập tên Layer chứa Text cần lọc (nếu layer chưa có, lisp sẽ tạo mới)

- chọn tên file xuất Text gốc, Lisp sẽ tự tao file chứa Text cần lọc với qui tắc : tên file gốc + _filter

vd : tên file gốc là Cadviet.csv -> tên file chứa Text cần lọc : Cadviet_filter.csv

Hy vọng hữu ích với bạn.

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

Tháng 8 19, 2010

Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2 file (Txt hoặc CSV)

Cách sử dụng :

gõ lệnh : Ftext (Filter Text)

- chọn Text

- nhập k/cách

- nhập tên Layer chứa Text cần lọc (nếu layer chưa có, lisp sẽ tạo mới)

- chọn tên file xuất Text gốc, Lisp sẽ tự tao file chứa Text cần lọc với qui tắc : tên file gốc + _filter

vd : tên file gốc là Cadviet.csv -> tên file chứa Text cần lọc : Cadviet_filter.csv

Hy vọng hữu ích với bạn.

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

Đã test chương trình của bạn,nhưng bạn xem lại chương trình xóa khiếp quá ,nhiều chỗ del hêt luôn ,không còn điểm nào.

File xuât ra phải có dạng là 4 cột: N0(Thứ Tự) X (Tọa độ X) Y (Tọa dộ Y) H (Độ cao- text trên màn hình).

Tháng 8 19, 2010

Đã test chương trình của bạn,nhưng bạn xem lại chương trình xóa khiếp quá ,nhiều chỗ del hêt luôn ,không còn điểm nào.
File xuât ra phải có dạng là 4 cột: N0(Thứ Tự) X (Tọa độ X) Y (Tọa dộ Y) H (Độ cao- text trên màn hình).

Xóa nhiều hay ít lphụ thuộc vào giá trị khoảng cách bạn nhập.

Theo tui nghĩ, vấn đề của bạn là : Xóa(chuyển Layer) các TEXT nằm chồng lấp lên nhau thì chính xác hơn.

File xuât ra phải có dạng là 4 cột: N0(Thứ Tự) X (Tọa độ X) Y (Tọa dộ Y) H (Độ cao- text trên màn hình)

- yêu cầu này không có ở bài đầu tiên (mới phát sinh) ?

Tháng 8 19, 2010

Bạn nên dùng trích dẫn để biết rằng mình đang trả lời ai.
Bạn nói sai rồi, kể cả bạn chạy lại lệnh n lần cũng vẫn thế thôi, mình đã xem cấu trúc file lisp của bạn và nếu chạy chương trình thì cũng cao nhất 80%.

Không phải mình nói bạn lập trình không tốt nhưng với cách thức giải bài toán trên, lisp không thể là 100% được bạn à.

Mong rằng bạn sẽ cho ra sản phẩm hoàn thiện, và tất nhiên, nếu bạn tạo ra được thì tên tuổi của bạn sẽ được lưu lại trên lisp, nếu lỡ mai này mình có ý tưởng hay đối với lisp của bạn thì chắc rằng mình sẽ communicate với bạn. Chúc bạn luôn vui vẻ và có nhiều đóng góp cho cadviet

Mô Phật. Tại hạ ở ẩn rồi, không màng danh lợi nữa

Còn các chương trình Autolisp mình đã viết hết đầy đủ với các ý tưởng đã xong nên tham gia diễn đàn này cho vui thôi

Bây giờ mình chỉ việc Enter là chạy ==> thiết kế xong ==> đi uống cafe chờ tự động in ==> tới tháng tiền vô TK

"Ngoảnh nhìn lại cuộc đời như giấc mộng

Được mất thành bại bỗng chốc hóa hư không"

Bon...bon...on...n...

Tháng 8 19, 2010

Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2 file (Txt hoặc CSV)

Cách sử dụng :

gõ lệnh : Ftext (Filter Text)

- chọn Text

- nhập k/cách

- nhập tên Layer chứa Text cần lọc (nếu layer chưa có, lisp sẽ tạo mới)

- chọn tên file xuất Text gốc, Lisp sẽ tự tao file chứa Text cần lọc với qui tắc : tên file gốc + _filter

vd : tên file gốc là Cadviet.csv -> tên file chứa Text cần lọc : Cadviet_filter.csv

Hy vọng hữu ích với bạn.

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

Nói như bạn NDBNGO: "Xoá khủng khiếp quá " không đúng vì lisp bác Gia_bach viết đúng theo yêu cầu của bạn đưa ra. Nhưng có một vấn đề khi chạy chương trình là bác đã xác định những text nào nằm đè lên nhau thì nó cũng xoá. Như vậy, nếu các text cứ nằm đè lên nhau và trải dài thì nó chỉ để lại text đầu tiên. Trong công việc đo sâu của chúng em khi đo trên sông thì đo bằng máy hồi âm nó sẽ đo liên tục và đến đoạn xoay tàu khi đo đến gần bờ thì nó sẽ có rất nhiều điểm gần và trùng nhau cần phải xoá bớt đi. Vì vậy lisp của bác Gia_Bach sẽ không giải quyết được vấn đề. Vậy em đưa ra một ý tưởng là bác có thể dùng mắt lưới để lọc text. Ví dụ như kích thước mắt lưới là 15x15 chẳng hạn, lưới kích thước 15x15 này bao trùm tất cả các text được chọn. Với mắt lưới như vậy, xét tất cả các text nằm trong cùng một ô với kích thước 15x15, text nào nằm gần với tâm của ô lưới nhất thì được giữ lại và xoá (hoặc tạo 1 layer có màu khác). Em đưa ra ý tưởng như thế có được không hả bác? Mong bác đóng góp ý kiến (ghi chú: text có tọa độ nằm trên cạnh mắt lưới thì xoá). Cảm ơn mọi người đã đóng góp ý kiến. Cảm ơn bác Gia_Bach, bác luôn lên tiếng đúng lúc mọi người cần. Thanks bác nhiều.

Tháng 8 19, 2010

Mô Phật. Tại hạ ở ẩn rồi, không màng danh lợi nữa
Còn các chương trình Autolisp mình đã viết hết đầy đủ với các ý tưởng đã xong nên tham gia diễn đàn này cho vui thôi

Bây giờ mình chỉ việc Enter là chạy ==> thiết kế xong ==> đi uống cafe chờ tự động in ==> tới tháng tiền vô TK

"Ngoảnh nhìn lại cuộc đời như giấc mộng

Được mất thành bại bỗng chốc hóa hư không"

Bon...bon...on...n...

Như vậy là lão tăng đã ở ẩn rồi à. Tiếc thay tiếc thay. Mong rằng lão tăng sẽ quay lại chốn trần tục để tiếp tục sự nghiệp đóng góp cho cadviet. Cảm ơn lão tăng nha

Tháng 8 19, 2010

Không như bạn Thanhduan2407 đâu chương trình này mình chạy thực nghiêm trên 2 chương trình với điều kiện như nhau khoảng cách là 2 m.

Với bạn vevezula thì 1 lần và Giabach cũng thế thì kết quả như sau:

-Ban vevezula xóa chưa hết .

-Chương trình giabach xóa nhiều quá ,chỗ được,nhưng nhiều chỗ ,nhiều lúc xóa trắng cả đoạn luôn.

Nhưng cũng cảm ơn tất cả đã tham gia.

Bạn giabach thêm cho mình là chỉ xóa trên 1 layer nhất đinh (Người sử dung yêu cầu sử dụng hoặc layer hiện hành nhé)

Mình gửi bản vẽ lên để các bạn xem nhé để giúp đỡ:

http://www.4shared.com/photo/n2oA0f7x/_2__gibach.html

Bạn giabach xem và giúp nhé

Tháng 8 19, 2010

Trong các bản vẽ,nhiều khi các text ( Thường gặp trong trắc địa,bản đồ)hay khi tôi chuyển các bản đồ tỷ lệ lớn thành bản đồ tỷ lệ nhỏ các điểm text dày đặc trên bản vẽ.Như vậy ta phải làm công tác thủ công mất nhiều thời gian để xoá các điểm thừa này
. ...

....
Trong công việc đo sâu của chúng em khi đo trên sông thì đo bằng máy hồi âm nó sẽ đo liên tục và đến đoạn xoay tàu khi đo đến gần bờ thì nó sẽ có rất nhiều điểm gần và trùng nhau cần phải xoá bớt đi. Vì vậy lisp của bác Gia_Bach sẽ không giải quyết được vấn đề. Vậy em đưa ra một ý tưởng là bác có thể dùng mắt lưới để lọc text. Ví dụ như kích thước mắt lưới là 15x15 chẳng hạn, lưới kích thước 15x15 này bao trùm tất cả các text được chọn. Với mắt lưới như vậy, xét tất cả các text nằm trong cùng một ô với kích thước 15x15, text nào nằm gần với tâm của ô lưới nhất thì được giữ lại và xoá (hoặc tạo 1 layer có màu khác).

.....

Tui không phải trong nghề nên cũng không hiểu hết được yêu cầu của các bạn.

Như đã viết ở trên, tui nghĩ vấn đề của các bạn là : Xóa(chuyển Layer) các TEXT nằm chồng lấp lên nhau sau đó xuất ra file các số liệu của TEXT.

Các bạn dùng thử LISP này xem có đáp ứng đuợc không.

- bổ sung : File xuât ra phải có 4 cột: N0(Text) X (Tọa độ X) Y (Tọa dộ Y) H (Tọa dộ Z)

(do không biết qui luật của Số thứ tự)

to NDBNGO : việc lọc LAYER không khó, cái chính là chúng ta thống nhất đuợc mục tiêu của vấn đề, đang chờ ý kiến của bạn. Đã chạy thử LISP trên file Cad bạn gửi.

(defun c:FText (/ 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))

Tháng 8 19, 2010

Bạn giabach phải cho người dùng nhập giá trị khoảng cách cần loại bỏ .Lisp của bạn chỉ tự xóa ở gần trong bản này ,với tỷ lệ khác thì không được.

bạn sửa giúp nhé.Sau đó mình bàn tiếp về số thứ tự được.

Xóa như bạn vevezula là được ,nhưng mỗi tội phải chạy 3-4 lần mới ưng ý.

Cảm ơn bạn.

Tháng 8 19, 2010

Tui không phải trong nghề nên cũng không hiểu hết được yêu cầu của các bạn.

Như đã viết ở trên, tui nghĩ vấn đề của các bạn là : Xóa(chuyển Layer) các TEXT nằm chồng lấp lên nhau sau đó xuất ra file các số liệu của TEXT.

Các bạn dùng thử LISP này xem có đáp ứng đuợc không.

- bổ sung : File xuât ra phải có 4 cột: N0(Text) X (Tọa độ X) Y (Tọa dộ Y) H (Tọa dộ Z)

(do không biết qui luật của Số thứ tự)

to NDBNGO : việc lọc LAYER không khó, cái chính là chúng ta thống nhất đuợc mục tiêu của vấn đề, đang chờ ý kiến của bạn. Đã chạy thử LISP trên file Cad bạn gửi.

(defun c:FText (/ 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))

Tuyệt vời.

Tháng 8 20, 2010

Bạn giabach phải cho người dùng nhập giá trị khoảng cách cần loại bỏ .Lisp của bạn chỉ tự xóa ở gần trong bản này ,với tỷ lệ khác thì không được.
bạn sửa giúp nhé.Sau đó mình bàn tiếp về số thứ tự được.

Xóa như bạn vevezula là được ,nhưng mỗi tội phải chạy 3-4 lần mới ưng ý.

Cảm ơn bạn.

với tỷ lệ khác thì không được. : Lisp ở trên không phụ thuộc vào tỉ lệ bản vẽ.

Update lisp : cho phép người dùng nhập giá trị khoảng cách cần loại bỏ.

- nói thêm về giá trị này : đó là khoảng cách từ đuờng bao của Text (tưong tự lệnh OFFSET)

Lisp sẽ lọc các Text có giao với đuờng bao Offset này (đuờng màu cyal)

File Cad kết quả : Filter_text.dwg

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

Tháng 8 20, 2010

Bạn giabach phải cho người dùng nhập giá trị khoảng cách cần loại bỏ .Lisp của bạn chỉ tự xóa ở gần trong bản này ,với tỷ lệ khác thì không được.
bạn sửa giúp nhé.Sau đó mình bàn tiếp về số thứ tự được.

Xóa như bạn vevezula là được ,nhưng mỗi tội phải chạy 3-4 lần mới ưng ý.

Cảm ơn bạn.

Xin chào bạn NDBNGO. Bác Gia_Bach ra tạo ra sản phẩm tuyệt vời như thế mà bạn lại chưa biết cách sử dụng. Hôm qua muộn quá rồi nên mình không thể post lên cách dùng hiệu quả lisp Ftext của bác Gia_bach. Bác ấy thật tuyệt vời cả về kỹ năng cũng như trình độ toán học. Mình mới học lập trình lisp, cũng chưa cho ra sản phẩm gì gọi là tâm đắc mà chỉ có ý chỉnh sửa theo ý của mình. (Hiểu được phương pháp và cách làm mới là 1 vấn đề để sau này nó ngấm mới thích). Theo cách của bạn là cần phải nhập giá trị khoảng cách vào phải không? Đơn giản, bạn xem chiều cao text hiện tại là bao nhiêu? bạn muốn khoảng cách là bao nhiêu? Xong rồi đấy, bạn chỉ cần cho chiều cao text tăng lên theo khoảng cách bạn muốn nhập vào là được, sau đó dùng lệnh ftext, bây giờ, bạn hãy cho chiều cao chữ trở về height ban đầu là được. Bạn thử làm theo tôi xem có ổn không. Nếu bạn không làm được thì tôi upload 1 bản vẽ ví dụ lên nhé:

http://www.4shared.com/photo/Y0kLvjnq/test.html

Mình post bài này hơi muộn một chút vì mình ko chắc là bác Gia_bach sử dụng phương pháp ấy. Nó liên quan đến đường bao textbox của text.

Tháng 8 20, 2010

Gửi tới bác Gia_bach

Chào bác gia_bach.

Em định lập ra một topic mới để bàn luận trong diễn đàn nhưng vấn đề em đưa ra hơi riêng tư một chút nên nhờ bác gia_bach cao thủ giúp đỡ.

Đây cũng là một bài toán cũng rất bổ ích cho việc lọc text. Em có file này bác xem giúp em:

http://www.4shared.com/file/VW0d810z/xuat_text.html

Xin nhờ bác lấy dùm em toạ độ (X, Y) của 2 text (thực chất là cùng một do justify căn chỉnh).

Về độ cao Z thì bottom right ta lấy phần nguyên và top left ta lấy ra phần thập phân sau dấu phẩy

Nếu bottom right (ctr+ u) thì là số dương và bottom right là số âm.

Sau khi quét chọn thì sẽ lưu ra tệp txt với định dạng STT X Y Z

Cảm ơn bác Gia_Bach rất nhiều. (Đó là số liệu chuyên ngành hàng hải bác ạ, họ chơi khó mình nên em không có cách nào khác bác ạ! hic)

Chờ tin bác

Tháng 8 20, 2010

Gửi tới bác Gia_bach
Chào bác gia_bach.

Em định lập ra một topic mới để bàn luận trong diễn đàn nhưng vấn đề em đưa ra hơi riêng tư một chút nên nhờ bác gia_bach cao thủ giúp đỡ.

Đây cũng là một bài toán cũng rất bổ ích cho việc lọc text. Em có file này bác xem giúp em:

http://www.4shared.com/file/VW0d810z/xuat_text.html

Xin nhờ bác lấy dùm em toạ độ (X, Y) của 2 text (thực chất là cùng một do justify căn chỉnh).

Về độ cao Z thì bottom right ta lấy phần nguyên và top left ta lấy ra phần thập phân sau dấu phẩy

Nếu bottom right (ctr+ u) thì là số dương và bottom right là số âm.

Sau khi quét chọn thì sẽ lưu ra tệp txt với định dạng STT X Y Z

Cảm ơn bác Gia_Bach rất nhiều. (Đó là số liệu chuyên ngành hàng hải bác ạ, họ chơi khó mình nên em không có cách nào khác bác ạ! hic)

Chờ tin bác

Sau khi quét chọn thì sẽ lưu ra tệp txt với định dạng STT X Y Z

STT : qui tắc đánh số STT ra sao ? lấy giá trị ở đâu ?

PS : Tui không chắc là có đủ thời gian để giúp bạn đuợc. :D

Đăng nhập

Viết giúp Lisp xoá text trong khoảng nhất định

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

NDBNGO 20

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

VUVUZELA 100

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

NDBNGO 20

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

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

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

NDBNGO 20

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

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

VUVUZELA 100

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

NDBNGO 20

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

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

NDBNGO 20

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

gia_bach 1.548

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

NDBNGO 20

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

gia_bach 1.548

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

VUVUZELA 100

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

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

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

NDBNGO 20

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

gia_bach 1.548

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

NDBNGO 20