Viết lisp theo yêu cầu [phần 2]

[phamngoctukts 714]

Chào bác Phamngoctukts,

Mình đã test cái lisp của bác trên cái file của bạn hdt và nhận được kết quả như sau:

http://www.cadviet.com/upfiles/3/tu1.jpg

Kết quả này không rõ bạn hdt4151 có hài lòng hay không nhưng mình thấy nó khác với cái của mình một số điểm như sau:

1/- Trong lisp của bác đã có đoạn xuất text ra file nằm cùng thư mục với bản vễ nhưng không hiểu sao mình tìm không thấy nó đâu cả để kiểm tra.

2/- Bác đã xóa các line và chỉ còn lại các boundary đơn

3/- Có một dòng text Region trong một boundary duy nhất, các boundary khác không có text.

4/- Khi lisp dừng chạy, nếu nhấn tiếp enter thì xuất hiện thông báo Xảy ra lỗi trong quá trình thao tác mà mình chưa biết thao tac sai chỗ nào bác ạ.

 

Và như vậy thì cái yêu cầu xác định boundary tương ứng với các text xuất ra có nhẽ sẽ có trục trặc bác ạ.

Cả cái việc xác định các điểm nằm trên boundary có nhẽ bác cũng chưa giải quyết thì phải.

 

Về tốc độ thì với cùng bản vẽ của bạn hdt4151, lisp của bác cho kết quả nhanh hơn lisp của mình mặc dầu mình chưa test được là nhanh hơn bao nhiêu lần bác ạ.

 

Hy vọng bác sẽ sớm hoàn thiện được cái lisp này.

Chào bác Bình lỗi này em cũng biết rồi nhưng chưa khắc phục.

Tại dòng (command "text" "j" "m" ptam "" (rtos id 2 0)) bác chuyển thành (command "text" "j" "m" ptam "" "" (rtos id 2 0)) là ok

hoặc bác vào style chỉnh height khác 0 là được.

[w1nDream 73]

Chào mọi người.Em muốn nhờ mọi người giúp đỡ em viết 1 con Lisp thực hiện 1 tổ hợp lệnh để làm các công việc như hình biểu diễn trong file dưới đây:

 

http://www.cadviet.com/upfiles/3/km15__km16.dwg

 

Em làm bên giao thông nên rất hay phải thực hiện các công việc trên với số lượng lớn nhưng lại toàn phải làm thủ công.Mong các Pác júp đỡ!

:cheers:

[hugo75 4]

Em có 1 đoạn lisp sau khi sử dụng lệnh RT thì mất truy bắt điểm và không thể undo được.Mong các bác sửa giùm.Chân thành cảm ơn trước.

http://www.cadviet.com/upfiles/3/acad_1.lsp

[w1nDream 73]

Em có 1 đoạn lisp sau khi sử dụng lệnh RT thì mất truy bắt điểm và không thể undo được.Mong các bác sửa giùm.Chân thành cảm ơn trước.

http://www.cadviet.com/upfiles/3/acad_1.lsp

 

Bạn xem được chưa nha.

 

http://www.cadviet.com/upfiles/3/acad_1_1.lsp

[ketxu 2.984]

Chào mọi người.Em muốn nhờ mọi người giúp đỡ em viết 1 con Lisp thực hiện 1 tổ hợp lệnh để làm các công việc như hình biểu diễn trong file dưới đây:

 

http://www.cadviet.com/upfiles/3/km15__km16.dwg

 

Em làm bên giao thông nên rất hay phải thực hiện các công việc trên với số lượng lớn nhưng lại toàn phải làm thủ công.Mong các Pác júp đỡ!

:cheers:

K down đc file của bạn bạn à :cheers:

[hugo75 4]

Bạn xem được chưa nha.

 

http://www.cadviet.com/upfiles/3/acad_1_1.lsp

UNDO được rồi nhưng vẫn mất truy bắt điểm.Mong các bác giúp giùm.Thanks

[phamngoctukts 714]

Chưa kết thúc được đâu bạn ạ

Code của bạn vẫn không chạy được

Cho Tue_NV rút lại lời góp ý thứ 4 dưới đây và đi theo thuật toán của bác TRUNGNGAMY. Vì rằng Tue_NV post bài trước mới có sự hồi âm của bác TRUNGNGAMY về ý tưởng thuật toán. Chọn 1 loạt đối tượng và xử lý luôn, không chọn theo từng nhóm nữa. Cái nữa, theo Tue_NV được biết là Lisp của bạn chưa đánh số thứ tự tăng dần trong cùng 1 nhóm thửa thì cũng là chưa triệt để lắm. Trong cùng 1 nhóm thửa không nên để các số thứ tự xen lẫn vào nhau. Nên có 1 quy luật đánh số thứ tự nào đó Nếu cứ để như vậy thì trong 1 đa giác lớn, muốn kiểm tra thửa đất nào, tìm trên bản vẽ giấy thì lòi mắt luôn, lại phải mở CAD ra tìm, thật là bất tiện lắm Bài toán này là 1 bài toán lớn, cần có thời gian giải quyết nên chưa thể kết thúc được. Vả lại bạn cũng chưa giải quyết triệt để các vấn đề trên cũng như về mặt tốc độ.......

Bác test tiếp giúp em nhé. không biết còn lỗi gì không. Cách sắp xếp thư tự như vậy đã được chưa?

(defun ndt();Nhom doi tuong
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget "x" '((0 . "line"))))
(setq lss (append lss (list ss)))
(taobo lss)
)

(defun taobo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(command "point" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(while (< j (sslength ss))
(setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (/= ssdk nil)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
)
) 
(setq i (1+ i))
)
(command "erase" list_point "")
(sapxep ss_pl)
)


(defun c:tdd ()
(inittdd)
(command "undo" "be")
(command "zoom" "e")
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p) 
i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3) 
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(setvar "osmode" oldos)
(command "undo" "e")
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq 
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)


(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re) 
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (cadr ps)) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
)
)

BS: code vẫn bị hơi lỗi đã edit lại rồi.

[tamkt 2]

Qua cái thông báo của CAD và nội dung lisp thì thấy nó chả có gì xung đột ở đây cả. Chỉ là cái lisp của bạn chạy chưa chuẩn khi bạn chọn điểm vào một polyline hở mà thôi. Bạn hãy thử lại xem.

 

Dạ em xài cad2010 bị như vậy, cad2007 thì ok anh ah.

Không biết cad2010 nó bị gì thì phải, em vẽ 1 hình vuông luôn đó.

mà vẫn bị báo lỗi là "không kín"

[tamkt 2]

Của bạn đây. Hơn cả sự mong đợi.

;; free lisp from cadviet.com
(defun c:dv ()
(setq ent (entget (car (entsel "\nchon doi tuong line L:")))
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
(if (> (car p1) (car p2)) 
(progn
(setq p2 (cdr (assoc 10 ent))
p1 (cdr (assoc 11 ent)))
)
)
(setq re (getreal "\nNhap doan chia DC: ")
caochu (getreal "\nNhap cao chu: ")
di (distance p1 p2)
chia (/ di re)
td (polar p1 (angle p1 p2) (/ di 2))
dc (polar td (+ (angle p1 p2) (/ pi 2)) caochu)
ghichu (strcat "L" (rtos di) "/DC" (rtos re) "=" (rtos chia) "PHÇN")
)
(ctext dc ghichu caochu (angle p1 p2))
)

(defun ctext (diem gt cc goc /)
(setq lst
(list
(cons 0 "TEXT")
(cons 1 gt)
(cons 10 diem)
(cons 40 cc)
(cons 50 goc)
)
)
(entmake lst)
(setq e (entget (entlast)))
(setq e (entmod (subst (cons 72 1) (cons 72 0) e)))
(entmod (subst (cons 11 dc) (assoc 11 e) e))
)

Đúng là hơn cả mong đợi rùi anh Tú ơi, có điều e muốm nó tự cho chiều cao chữ là 250mm.

Em vọc 2 tiếng rùi, mà không chỉnh được cho lisp tự hiểu là chiều cao chữ 250mm.

Anh giúp e với.

[nguyentuyen6 130]

(if (= caochu nil) (setq caochu 250)) bạn thêm dòng này vào sau caochu (getreal "\nNhap cao chu: ") xem dc ko.

[phamngoctukts 714]

Đúng là hơn cả mong đợi rùi anh Tú ơi, có điều e muốm nó tự cho chiều cao chữ là 250mm.

Em vọc 2 tiếng rùi, mà không chỉnh được cho lisp tự hiểu là chiều cao chữ 250mm.

Anh giúp e với.

Của bạn đây.

;; free lisp from cadviet.com
(defun c:dv ()
(setq ent (entget (car (entsel "\nchon doi tuong line L:")))
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
(if (> (car p1) (car p2)) 
(progn
(setq p2 (cdr (assoc 10 ent))
p1 (cdr (assoc 11 ent)))
)
)
(setq re (getreal "\nNhap doan chia DC: ")
caochu (cond (caochu) (250))
oldchu caochu
caochu (getreal (strcat "\nNhap cao chu <"(rtos oldchu 2 0)">: ")))
(if (= caochu nil) (setq caochu oldchu))
(setq di (distance p1 p2)
chia (/ di re)
td (polar p1 (angle p1 p2) (/ di 2))
dc (polar td (+ (angle p1 p2) (/ pi 2)) caochu)
ghichu (strcat "L" (rtos di) "/DC" (rtos re) "=" (rtos chia) "PHÇN")
)
(ctext dc ghichu caochu (angle p1 p2))
)

(defun ctext (diem gt cc goc /)
(setq lst
(list
(cons 0 "TEXT")
(cons 1 gt)
(cons 10 diem)
(cons 40 cc)
(cons 50 goc)
)
)
(entmake lst)
(setq e (entget (entlast)))
(setq e (entmod (subst (cons 72 1) (cons 72 0) e)))
(entmod (subst (cons 11 dc) (assoc 11 e) e))
)

[tamkt 2]

Của bạn đây.

;; free lisp from cadviet.com
(defun c:dv ()
(setq ent (entget (car (entsel "\nchon doi tuong line L:")))
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
(if (> (car p1) (car p2)) 
(progn
(setq p2 (cdr (assoc 10 ent))
p1 (cdr (assoc 11 ent)))
)
)
(setq re (getreal "\nNhap doan chia DC: ")
caochu (cond (caochu) (250))
oldchu caochu
caochu (getreal (strcat "\nNhap cao chu <"(rtos oldchu 2 0)">: ")))
(if (= caochu nil) (setq caochu oldchu))
(setq di (distance p1 p2)
chia (/ di re)
td (polar p1 (angle p1 p2) (/ di 2))
dc (polar td (+ (angle p1 p2) (/ pi 2)) caochu)
ghichu (strcat "L" (rtos di) "/DC" (rtos re) "=" (rtos chia) "PHÇN")
)
(ctext dc ghichu caochu (angle p1 p2))
)

(defun ctext (diem gt cc goc /)
(setq lst
(list
(cons 0 "TEXT")
(cons 1 gt)
(cons 10 diem)
(cons 40 cc)
(cons 50 goc)
)
)
(entmake lst)
(setq e (entget (entlast)))
(setq e (entmod (subst (cons 72 1) (cons 72 0) e)))
(entmod (subst (cons 11 dc) (assoc 11 e) e))
)

Đúng tuyệt, hehe.

E cũng đang tìm hiểu lisp, hay quá.

Em cám ơn anh Tú nhiều nhiều.

[gia_bach 1.549]

.......

Mà e xài líp này thì líp tính diện tích của 1 vùng kín của e bị lỗi, không biết có phải là bị xung đột không nữa, hichic, e gà líp quá. Mong mấy a giúp em với.

Đây là lisp diện tích miền, e tải trên Cadviet:

(defun c:dtm()
(defun ctext (diem gt / lst)
(setq lst
(list
(cons 0 "TEXT")
(cons 1 gt)
(cons 10 diem)
(cons 40 (getdist p "\nChieu cao chu: "))
)
)
(entmake lst)
)
(defun dtdoituong (entdt /)
(command ".area" "o" entdt)
(command ".erase" entdt "")
(getvar "area")
)
(defun getbound(p)
(setq ent (entlast))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ent1 (entlast))
(cond
((eq ent ent1) nil)
(t ent1)
)
)
(princ "\nCADViet.com © 2007")
(setq
p (getpoint "\nVao diem can tinh dien tich: ")
entpl (getbound p)
)
(if entpl
(ctext p (rtos (dtdoituong entpl)))
(alert "Diem ban chon khong kin!")
)
(princ)
)

(princ "\ndtm - free lisp from www.cadviet.com")
(princ) 

Bạn thử thay dòng :

(command ".boundary" "A" "B" "E" "I" "Y" "" p "")

bằng dòng :

(command "boundary" p "")

[w1nDream 73]

K down đc file của bạn bạn à :cheers:

 

Mình vừa thử Down vẫn được mà bạn ơi.

:cheers:

[hugo75 4]

Bạn xem được chưa nha.

 

http://www.cadviet.com/upfiles/3/acad_1_1.lsp

UNDO được rồi nhưng khi UNDO nó mất truy bắt điểm.Mình đã thử làm như cách các bác chỉ trên diễn đàn nhưng không được.Mong các bác giúp đỡ.Chân thành cảm ơn trước.

[Tue_NV 3.912]

Bác test tiếp giúp em nhé. không biết còn lỗi gì không. Cách sắp xếp thư tự như vậy đã được chưa?

(defun ndt();Nhom doi tuong
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget "x" '((0 . "line"))))
(setq lss (append lss (list ss)))
(taobo lss)
)

(defun taobo ( lss / )
(setq k 0 list_point (ssadd))
(while ((setq ss (nth k lss))
(setq i 0)
(while ((setq name (ssname ss i)
ent (entget name)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(command "point" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(while ((setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while ((setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while ((setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (/= ssdk nil)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
)
) 
(setq i (1+ i))
)
(command "erase" list_point "")
(sapxep ss_pl)
)
(defun c:tdd ()
(inittdd)
(command "undo" "be")
(command "zoom" "e")
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq p 0)
(while ((setq name (ssname ssmoi p) 
i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3) 
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(setvar "osmode" oldos)
(command "undo" "e")
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq 
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)
(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re) 
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while ((setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (cadr ps)) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
)
)

BS: code vẫn bị hơi lỗi đã edit lại rồi.

Trước tiên, Tue_NV cảm ơn bạn Tú đã bỏ khá nhiều thời gian để viết Lisp này. Tuy nhiên, vẫn còn tồn tại 1 số khuyết điểm lớn như sau :

1. Việc sắp xếp vẫn lộn xộn, không có trật tự gì cả. Test trên nhiều nhóm thửa, mỗi nhóm thửa là 1 đa giác thửa mẹ có nhiều thửa con.

2. Ý Tue_NV nói là chọn 1 loạt đối tượng để xử lý, chứ không phải là tự động chọn tất cả đa giác thửa để xử lý. Chọn 1 loạt đối tượng là chọn nhiều nhóm thửa mẹ khác nhau, trong đó có nhiều thửa con. Lisp chọn luôn tất cả thửa để xử lý luôn như vậy là chưa phù hợp, trong khi User chỉ muốn chọn 1, 2 hay 3... nhóm thửa mẹ(có 1 hay nhiều thửa con để xử lý mà thôi)

3. Nhược điểm lớn nhất là : Khi chạy Lisp xong, các Pline, hay Line hay chính đối tượng gốc bị xóa mất rồi. Điều này hoàn toàn không nên. Nên trả lại những gì mà User đã có ban đầu.

Bạn làm Tue_NV liên tưởng tới bài hát này và hãy thư giãn với ca khúc này nhé :

Trả lại em yêu

Nếu không "trả lại", "em yêu" "bắt đền" đó :cheers:

[huong259 351]

Bạn làm Tue_NV liên tưởng tới bài hát này và hãy thư giãn với ca khúc này nhé :

Trả lại em yêu

Nếu không "trả lại", "em yêu" "bắt đền" đó :cheers:

Anh Tuệ ơi!

Xin anh đừng :

” Trả lại em yêu khung trời mùa hạ”

Và em cũng xin anh:

“Đừng ra đi về miền cát nóng”

Và xin anh:

đừng giận em anh nhé!

Em không dám

bắt đền anh đâu

đừng nghĩ oan em thế!

[phamngoctukts 714]

Trước tiên, Tue_NV cảm ơn bạn Tú đã bỏ khá nhiều thời gian để viết Lisp này. Tuy nhiên, vẫn còn tồn tại 1 số khuyết điểm lớn như sau :

1. Việc sắp xếp vẫn lộn xộn, không có trật tự gì cả. Test trên nhiều nhóm thửa, mỗi nhóm thửa là 1 đa giác thửa mẹ có nhiều thửa con.

2. Ý Tue_NV nói là chọn 1 loạt đối tượng để xử lý, chứ không phải là tự động chọn tất cả đa giác thửa để xử lý. Chọn 1 loạt đối tượng là chọn nhiều nhóm thửa mẹ khác nhau, trong đó có nhiều thửa con. Lisp chọn luôn tất cả thửa để xử lý luôn như vậy là chưa phù hợp, trong khi User chỉ muốn chọn 1, 2 hay 3... nhóm thửa mẹ(có 1 hay nhiều thửa con để xử lý mà thôi)

3. Nhược điểm lớn nhất là : Khi chạy Lisp xong, các Pline, hay Line hay chính đối tượng gốc bị xóa mất rồi. Điều này hoàn toàn không nên. Nên trả lại những gì mà User đã có ban đầu.

Bạn làm Tue_NV liên tưởng tới bài hát này và hãy thư giãn với ca khúc này nhé :

Trả lại em yêu

Nếu không "trả lại", "em yêu" "bắt đền" đó :cheers:

Chào bác Tue_VN! Cám ơn bác đã test và cho ý kiến. Vì không phải là dân chắc địa nên em không lường trước được hết các tình huống được bán thông cảm nhé.

1. cái này em cũng đang đau đầu vì thuật toán sắp xếp đối tượng. Bác nào rành về vấn đề này thì giúp em với.

2. Cái này thì dễ chỉ cần bỏ "x" trong ssget là được.

3. Cái này cũng không thành vấn đề. Em đã giải quyết được rồi.

[phamthanhbinh 3.146]

Trước tiên, Tue_NV cảm ơn bạn Tú đã bỏ khá nhiều thời gian để viết Lisp này. Tuy nhiên, vẫn còn tồn tại 1 số khuyết điểm lớn như sau :

1. Việc sắp xếp vẫn lộn xộn, không có trật tự gì cả. Test trên nhiều nhóm thửa, mỗi nhóm thửa là 1 đa giác thửa mẹ có nhiều thửa con.

2. Ý Tue_NV nói là chọn 1 loạt đối tượng để xử lý, chứ không phải là tự động chọn tất cả đa giác thửa để xử lý. Chọn 1 loạt đối tượng là chọn nhiều nhóm thửa mẹ khác nhau, trong đó có nhiều thửa con. Lisp chọn luôn tất cả thửa để xử lý luôn như vậy là chưa phù hợp, trong khi User chỉ muốn chọn 1, 2 hay 3... nhóm thửa mẹ(có 1 hay nhiều thửa con để xử lý mà thôi)

3. Nhược điểm lớn nhất là : Khi chạy Lisp xong, các Pline, hay Line hay chính đối tượng gốc bị xóa mất rồi. Điều này hoàn toàn không nên. Nên trả lại những gì mà User đã có ban đầu.

Bạn làm Tue_NV liên tưởng tới bài hát này và hãy thư giãn với ca khúc này nhé :

Trả lại em yêu

Nếu không "trả lại", "em yêu" "bắt đền" đó :cheers:

Hề hề hề,

Bác Tue_NV ơi,

Thực ra cái việc sắp xếp này ấy là do mấy anh cu địa chính làm, mình thấy các bản vẽ của mấy anh cu đó cũng lộn xộn ghê gớm, chả có quy luật quy liệc gì cả. Hình như với các anh cu ấy thì cái quy luật lại là tùy hứng bác ạ.

Vì lẽ đó cho nên người dùng phải đưa ra được cái gọi là quy luật ấy thì lisper mới viết được, còn bảo là tự định ra quy luật thì có khi mấy anh cu ấy lại bảo là chơi trèo bác ạ.

Hề hề hề....

[phamthanhbinh 3.146]

Chào bác Tue_VN! Cám ơn bác đã test và cho ý kiến. Vì không phải là dân chắc địa nên em không lường trước được hết các tình huống được bán thông cảm nhé.

1. cái này em cũng đang đau đầu vì thuật toán sắp xếp đối tượng. Bác nào rành về vấn đề này thì giúp em với.

2. Cái này thì dễ chỉ cần bỏ "x" trong ssget là được.

3. Cái này cũng không thành vấn đề. Em đã giải quyết được rồi.

Hề hề hề,

cái vụ sắp xếp ấy khó mà cũng chả khó lắm bác ạ, vấn đề là phải hiểu cái quy luạt họ cần mà thôi. Tỷ như từ trên xuống, từ dưới lên, từ bé đến to vv.....

Hề hề hề, bác cứ chọn cái nào khoái mà chơi vì đó là cái quy luật của bác , có ai bắt bò đâu mà bác lo....

[w1nDream 73]

Chào mọi người.Em muốn nhờ mọi người giúp đỡ em viết 1 con Lisp thực hiện 1 tổ hợp lệnh để làm các công việc như hình biểu diễn trong file dưới đây:

 

http://www.cadviet.com/upfiles/3/km15__km16.dwg

 

Em làm bên giao thông nên rất hay phải thực hiện các công việc trên với số lượng lớn nhưng lại toàn phải làm thủ công.Mong các Pác júp đỡ!

:cheers:

 

Các Pác ơi!

Không ai giúp em à.Em đang rất cần.Mong tin................!

:cheers:

[phamngoctukts 714]

Hề hề hề,

cái vụ sắp xếp ấy khó mà cũng chả khó lắm bác ạ, vấn đề là phải hiểu cái quy luạt họ cần mà thôi. Tỷ như từ trên xuống, từ dưới lên, từ bé đến to vv.....

Hề hề hề, bác cứ chọn cái nào khoái mà chơi vì đó là cái quy luật của bác , có ai bắt bò đâu mà bác lo....

Chào bác Bình.

Quả thật việc sắp xếp này đối với em là rất khó vì chưa làm trường hợp này bao giờ. Cái khó ở đây là sắp xếp lại trật tự của selection set. em đã làm riêng trong phần (defun sapxep () ....). Các bác nghiên cứu xem có thể giúp được cho em không. Em muốn sắp xếp đơn giản là từ trên xuống dưới từ trái qua phải thôi bác ạ.

code mới đây đã fix ý 2 và 3 của Bác Tue_VN.

;; free lisp from cadviet.com
(defun ndt();Nhom doi tuong
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget '((0 . "line"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(taobo lss)
)

(defun taobo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(command "point" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(while (< j (sslength ss))
(setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (/= ssdk nil)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
)
) 
(setq i (1+ i))
)
(command "erase" list_point "")
(sapxep ss_pl)
)


(defun c:tdd ()
(inittdd)
(command "undo" "be")
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
list_chu (ssadd)
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p)) 
(command "area" "o" name)
(setq i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0) " dien tich: " (rtos (getvar "area") 2 3))) dlst1)
)
(setq ptam (centroid name))
(setq tx (getvar "textstyle"))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(setq list_chu (ssadd (entlast) list_chu))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3) 
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(command "_.copyclip" list_chu "")
(command "block" "chu" "0,0" list_chu "")
(command "insert" "chu" "0,0" "" "" "")
(setq pchu (nth 0 (acet-ent-geomextents (entlast))))
(setvar "osmode" oldos)
(command "undo" "e")
(command "undo" "")
(command "_.pasteclip" pchu)
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq 
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)


(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re) 
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (- (cadr ps) (car ps))) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(setq m 0)
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
(setq m (1+ m))
)
)

[gia_bach 1.549]

Hề hề hề,

Bác Tue_NV ơi,

Thực ra cái việc sắp xếp này ấy là do mấy anh cu địa chính làm, mình thấy các bản vẽ của mấy anh cu đó cũng lộn xộn ghê gớm, chả có quy luật quy liệc gì cả. Hình như với các anh cu ấy thì cái quy luật lại là tùy hứng bác ạ.

Vì lẽ đó cho nên người dùng phải đưa ra được cái gọi là quy luật ấy thì lisper mới viết được, còn bảo là tự định ra quy luật thì có khi mấy anh cu ấy lại bảo là chơi trèo bác ạ.

Hề hề hề....

Tóm lại là cái anh nào đó Post yêu cầu lên rồi chẳng thấy đâu cả ?

Chỉ còn các Lisper trao đổi với nhau thôi.

Đôi khi tôi nghĩ có nên theo đuổi vấn đề này nữa không? Nhưng ....

"Lỡ yêu rồi ..." : chua cay mặn ngọt ... gì gì nữa cũng "trăm dâu đổ đầu tằm".

 

tôi có ý này : Bài toán này chỉ cần tập trung vào giải quyết Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc), vấn đề trích xuất tọa độ khi đã có đuờng bao là chuyện nhỏ (các bác cũng viết nhiều rồi).

 

Về Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc) thì có 2 cách :

1. Ph/án của phamngoctukts

- break tất cả các đối tuợng tại điểm giao

- tạo Region với các đối tuợng vừa break

- convert các region thành Pline (xóa Pline bao trùm)

 

2. Ph/án của bác Bình

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này : tạo Boundary

- xóa các Boundary trùng nhau

 

Vài dòng, chúc các bác cuối tuần "vui vẻ với nguời yêu".

 

Lisp cải tiến từ lisp xpatp của bác Bình.

Nội dung chính :

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này :

+ nếu tạo đuợc Boundary : duyệt qua các đỉnh của Boundary xóa các điểm này trong tập giao điểm ớ buớc 1

Kết quả : chỉ tạo đuợc khoảng 90% Boundary nhưng tốc độ chấp nhận đuợc.

(defun c:xpatp (/ boun boundFlag dis_min i j nEnt plst pt sec ss time tmp vl ov rempt)  
 (if (setq ss (ssget (list (cons 0 "LINE,LWPOLYLINE,ARC"))))
   (progn
     (command "undo" "be")
     (setq time (getvar "millisecs"))
     (setq nEnt (entlast)
    vl '("BLIPMODE" "CMDECHO" "OSMODE") ; Sys Var list
    ov (mapcar 'getvar vl))   ; Get Old values
     (mapcar 'setvar vl '( 0 0 0))
     (setq j 0
    plst (getSS_Inter ss)
    plst (vl-sort plst '(lambda (x y)(or (< (cadr x)(cadr y))
				     (and (< (car x)(car y))
					  (= (cadr x)(cadr y))) ) ))
    dis_min (* 0.8(getDistan_min plst)))
     (while plst
(setq i 0 
      boundFlag t
      pt (car plst)
      plst (cdr plst))
(while (and boundFlag (< i 24))
  (setq tmp (polar pt (+ 3.2 (* 0.25 i)) dis_min))
  (if (and
	(not (ssget tmp));Point is directly on an object.
	(MakeBPoly tmp) )
    (progn
      (setq boun (entlast) k (1+ k)
	    boundFlag nil)
      (foreach bounPt (poly-pts boun)
	(if (setq rempt (member1 bounPt plst))
	  (setq plst (vl-remove rempt plst)) ))))
  (setq i (1+ i))  )  )
     (setq sec (/ (- (getvar "MILLISECS") time) 1000.0)  )
     (while (setq nEnt (entnext nEnt))
(setq j (1+ j))	)
     (if (> j 0)
(princ (strcat "\nTao duoc " (itoa j) " duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!")))
     (mapcar 'setvar vl ov)
     (command "undo" "e"))
   (princ (strcat "\nKhong chon duoc doi tuong!")))
 (princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MakeBPoly (pt / ele)
 (setq ele (entlast))
 (if(vl-cmdf "_BPOLY" "_A" "_I" "_N" "" "" pt "");(vl-cmdf "boundary" pt "")
   (if (not(equal (entlast) ele)) t )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun giao (ob1 ob2 / inter_lst iplist)
 (if (not (vl-catch-all-error-p
     (setq iplist (vl-catch-all-apply
		    'vlax-safearray->list
		    (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone) ))))))
   (progn
     (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
	   iplist (cdddr iplist)))
     (reverse inter_lst) ) ))

(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
 (setq i -1)
 (while (setq e (ssname ss (setq i (1+ i))))
   (setq lst (cons (vlax-ename->vla-object e) lst)) )
 (repeat (1- (vl-list-length lst))
   (setq obj (car lst))
   (foreach ob1 (setq lst (vl-remove obj lst ))
     (if ;(setq tmp_lst (giao ob1 obj))
(and
    (not (equal ob1 obj))
    (setq tmp_lst (giao ob1 obj)) )
(foreach pt tmp_lst
  (if (not (vl-position pt giao_lst))
    (setq giao_lst (cons pt giao_lst))))) ) )
 giao_lst )

(defun poly-pts (pl / n p l)
 (vl-load-com)
 (setq n (fix (vlax-curve-getEndParam pl)))
 (or (vlax-curve-IsClosed pl) (setq n (1+ n)))
 (while (setq p (vlax-curve-getPointAtParam pl (setq n (1- n))))
   (setq l (cons p l))  ))

(defun member1 (a b / res)
 (if b
   (foreach x b
     (if (equal x a 0.1)
       (setq res x) ) ) )
 res)

(defun getDistan_min (lst / dis pt1 tmp)
 (setq dis (distance (car lst) (cadr lst)))
 (repeat (1- (vl-list-length lst))
   (setq pt1 (car lst))
   (foreach pt2 (setq lst (vl-remove pt1 lst ))
     (if (< (setq tmp (distance pt1 pt2)) dis)
(setq dis tmp)	) ) ) 
 dis )

[phamngoctukts 714]

Tóm lại là cái anh nào đó Post yêu cầu lên rồi chẳng thấy đâu cả ?

Chỉ còn các Lisper trao đổi với nhau thôi.

Đôi khi tôi nghĩ có nên theo đuổi vấn đề này nữa không? Nhưng ....

"Lỡ yêu rồi ..." : chua cay mặn ngọt ... gì gì nữa cũng "trăm dâu đổ đầu tằm".

 

tôi có ý này : Bài toán này chỉ cần tập trung vào giải quyết Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc), vấn đề trích xuất tọa độ khi đã có đuờng bao là chuyện nhỏ (các bác cũng viết nhiều rồi).

 

Về Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc) thì có 2 cách :

1. Ph/án của phamngoctukts

- break tất cả các đối tuợng tại điểm giao

- tạo Region với các đối tuợng vừa break

- convert các region thành Pline (xóa Pline bao trùm)

 

2. Ph/án của bác Bình

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này : tạo Boundary

- xóa các Boundary trùng nhau

 

Vài dòng, chúc các bác cuối tuần "vui vẻ với nguời yêu".

 

Lisp cải tiến từ lisp xpatp của bác Bình.

Nội dung chính :

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này :

+ nếu tạo đuợc Boundary : duyệt qua các đỉnh của Boundary xóa các điểm này trong tập giao điểm ớ buớc 1

Kết quả : chỉ tạo đuợc khoảng 90% Boundary nhưng tốc độ chấp nhận đuợc.

(defun c:xpatp (/ boun boundFlag dis_min i j nEnt plst pt sec ss time tmp vl ov rempt)  
 (if (setq ss (ssget (list (cons 0 "LINE,LWPOLYLINE,ARC"))))
   (progn
     (command "undo" "be")
     (setq time (getvar "millisecs"))
     (setq nEnt (entlast)
    vl '("BLIPMODE" "CMDECHO" "OSMODE") ; Sys Var list
    ov (mapcar 'getvar vl))   ; Get Old values
     (mapcar 'setvar vl '( 0 0 0))
     (setq j 0
    plst (getSS_Inter ss)
    plst (vl-sort plst '(lambda (x y)(or (< (cadr x)(cadr y))
				     (and (< (car x)(car y))
					  (= (cadr x)(cadr y))) ) ))
    dis_min (* 0.8(getDistan_min plst)))
     (while plst
(setq i 0 
      boundFlag t
      pt (car plst)
      plst (cdr plst))
(while (and boundFlag (< i 24))
  (setq tmp (polar pt (+ 3.2 (* 0.25 i)) dis_min))
  (if (and
	(not (ssget tmp));Point is directly on an object.
	(MakeBPoly tmp) )
    (progn
      (setq boun (entlast) k (1+ k)
	    boundFlag nil)
      (foreach bounPt (poly-pts boun)
	(if (setq rempt (member1 bounPt plst))
	  (setq plst (vl-remove rempt plst)) ))))
  (setq i (1+ i))  )  )
     (setq sec (/ (- (getvar "MILLISECS") time) 1000.0)  )
     (while (setq nEnt (entnext nEnt))
(setq j (1+ j))	)
     (if (> j 0)
(princ (strcat "\nTao duoc " (itoa j) " duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!")))
     (mapcar 'setvar vl ov)
     (command "undo" "e"))
   (princ (strcat "\nKhong chon duoc doi tuong!")))
 (princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MakeBPoly (pt / ele)
 (setq ele (entlast))
 (if(vl-cmdf "_BPOLY" "_A" "_I" "_N" "" "" pt "");(vl-cmdf "boundary" pt "")
   (if (not(equal (entlast) ele)) t )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun giao (ob1 ob2 / inter_lst iplist)
 (if (not (vl-catch-all-error-p
     (setq iplist (vl-catch-all-apply
		    'vlax-safearray->list
		    (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone) ))))))
   (progn
     (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
	   iplist (cdddr iplist)))
     (reverse inter_lst) ) ))

(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
 (setq i -1)
 (while (setq e (ssname ss (setq i (1+ i))))
   (setq lst (cons (vlax-ename->vla-object e) lst)) )
 (repeat (1- (vl-list-length lst))
   (setq obj (car lst))
   (foreach ob1 (setq lst (vl-remove obj lst ))
     (if ;(setq tmp_lst (giao ob1 obj))
(and
    (not (equal ob1 obj))
    (setq tmp_lst (giao ob1 obj)) )
(foreach pt tmp_lst
  (if (not (vl-position pt giao_lst))
    (setq giao_lst (cons pt giao_lst))))) ) )
 giao_lst )

(defun poly-pts (pl / n p l)
 (vl-load-com)
 (setq n (fix (vlax-curve-getEndParam pl)))
 (or (vlax-curve-IsClosed pl) (setq n (1+ n)))
 (while (setq p (vlax-curve-getPointAtParam pl (setq n (1- n))))
   (setq l (cons p l))  ))

(defun member1 (a b / res)
 (if b
   (foreach x b
     (if (equal x a 0.1)
       (setq res x) ) ) )
 res)

(defun getDistan_min (lst / dis pt1 tmp)
 (setq dis (distance (car lst) (cadr lst)))
 (repeat (1- (vl-list-length lst))
   (setq pt1 (car lst))
   (foreach pt2 (setq lst (vl-remove pt1 lst ))
     (if (< (setq tmp (distance pt1 pt2)) dis)
(setq dis tmp)	) ) ) 
 dis )

Tại sao lại được có 90% vậy bác nhỉ. Em chưa đọc code mới test thử thì thấy tốc độ cưc nhanh nhưng lại thiếu mất mấy cáo boundary.

[phamthanhbinh 3.146]

Các Pác ơi!

Không ai giúp em à.Em đang rất cần.Mong tin................!

:cheers:

Chào bạn W1ndream,

Mình đã đọc yêu cầu của bạn song có một số điểm chưa rõ muốn hỏi lại bạn như sau:

1/- Cái hình bạn post lên tìm hoài chả thấy chỗ nào giống như cái yêu cầu cả, tức là chả có chỗ nào thấy cái text -0.00 màu vàng và text 0.00 màu xanh cả.

2/- Có phải bạn muốn chỉnh tất cả các text màu vàng mà bị chồng lên nhau thành các text cách đều nhau không??? Như vậy thì vị trí của nó có thể sẽ không còn tương thích với vị trí thực trên bản vẽ. Điều này có ảnh hưởng gì đến công việc của bạn hay không???

3/- Bạn chỉ hiệu chỉnh các text có width factor là 0.8 thôi hay tất cả các text bất kể width factor của nó.

4/- Có thể thay thế việc dãn các text ra bằng việc xóa bớt các text chồng lên nhau để đảm bảo giữ đúng vị trí của các text tương ứng với vị trí thực trên bản vẽ hay không???

 

Nhìn chung yêu cầu của bạn là có thể thực hiện được, tuy nhiên bạn cần gửi một bản vẽ thể hiện hai trạng thái trước và sau khi chạy lisp với đúng tình trạng thực của nó chứ không phải là copy cái ảnh ví dụ ra. (do trên bản vẽ bạn gửi mình tìm không thấy cái đoạn mẫu đó nên không biết phải thử lisp ở đâu trên bản vẽ của bạn) Bạn hãy đánh dấu cái vị trí cần chỉnh sửa của bạn trên bản vẽ. Nhớ là bản vẽ chứ không phải file ảnh vì khi viết lisp sẽ cần sử dụng tới các thuộc tính của các đối tượng trên bả vẽ của bạn, mà file ảnh thì không thể có các thuộc tính này.

 

Chờ sự hồi âm của bạn.