Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
48 replies to this topic

#1 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 18 August 2010 - 12:42 PM

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
  • 0

#2 VUVUZELA

VUVUZELA

    biết lệnh chamfer

  • Members
  • PipPipPipPip
  • 210 Bài viết
Điểm đánh giá: 97 (tàm tạm)

Đã gửi 18 August 2010 - 01:35 PM

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

  • 3

Hệ thống Liên Kết, Thiết Kế Tự Động

ttps://www.facebook...etThietKeTuDong


#3 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 18 August 2010 - 02:18 PM

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
  • 0

#4 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 18 August 2010 - 02:23 PM

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á.
  • 1



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#5 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 18 August 2010 - 02:33 PM

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.c...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.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#6 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 18 August 2010 - 02:35 PM

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
  • 0

#7 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 18 August 2010 - 03:27 PM

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



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#8 VUVUZELA

VUVUZELA

    biết lệnh chamfer

  • Members
  • PipPipPipPip
  • 210 Bài viết
Điểm đánh giá: 97 (tàm tạm)

Đã gửi 19 August 2010 - 10:42 AM

Đ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.
  • 0

Hệ thống Liên Kết, Thiết Kế Tự Động

ttps://www.facebook...etThietKeTuDong


#9 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 19 August 2010 - 10:54 AM

Đú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
  • 0

#10 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 19 August 2010 - 11:00 AM

Đ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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#11 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 19 August 2010 - 11:07 AM

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

#12 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 19 August 2010 - 11:22 AM

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

  • 1

#13 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 19 August 2010 - 11:43 AM

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).
  • 0

#14 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 19 August 2010 - 12:44 PM

Đã 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) ?
  • 0

#15 VUVUZELA

VUVUZELA

    biết lệnh chamfer

  • Members
  • PipPipPipPip
  • 210 Bài viết
Điểm đánh giá: 97 (tàm tạm)

Đã gửi 19 August 2010 - 02:24 PM

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

Hệ thống Liên Kết, Thiết Kế Tự Động

ttps://www.facebook...etThietKeTuDong


#16 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 19 August 2010 - 02:46 PM

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



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#17 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 19 August 2010 - 02:52 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#18 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 19 August 2010 - 03:18 PM

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.c..._2__gibach.html
Bạn giabach xem và giúp nhé
  • 0

#19 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 19 August 2010 - 03:58 PM

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

  • 2

#20 NDBNGO

NDBNGO

    biết lệnh rotate

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

Đã gửi 19 August 2010 - 05:12 PM

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