Đến nội dung


Hình ảnh
* * * - - 8 Bình chọn

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


  • Chủ đề bị khóa Chủ đề bị khóa
3783 replies to this topic

#2221 tamkt

tamkt

    biết vẽ ellipse

  • Members
  • PipPip
  • 51 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 13 October 2010 - 11:47 PM

Của bạn đây


;; free lisp from cadviet.com
(defun c:dv ()
(setq ent (entget (car (entsel "\nchon doi tuong line")))
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
re (getreal "\nNhap doan chia: ")
di (distance p1 p2)
chia (/ di re)
)
(alert (strcat "line dai: "
(rtos di)
"/doan chia: "
(rtos re)
" = "
(rtos chia)
" phan")
)
)


Anh viết như xiếc vậy, hay thật. E cám ơn anh nhiều. 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.

Nó bị dậy nè , đây là nguyên văn dòng báo:

" Command: DTM
CADViet.com © 2007
Vao diem can tinh dien tich: .boundary
Specify internal point or [Advanced options]: A
Enter an option [Boundary set/Island detection/Object type]: B
Specify candidate set for boundary [New/Everything] : E Selecting
everything visible...
Analyzing the selected data...

Enter an option [Boundary set/Island detection/Object type]: I
Do you want island detection? [Yes/No] : Y
Enter an option [Boundary set/Island detection/Object type]:
Specify internal point or [Advanced options]:
Valid hatch boundary not found.
Specify internal point or [Advanced options]:
Command: "

Đâ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) "

Ah, em muốn ghi luôn cả kết quả chia lên bản vẽ như lisp dtm vậy. Anh Tú chỉnh lại giúp e nha. Em cám ơn anh.
  • 0

#2222 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3805 (đỉnh cao)

Đã gửi 14 October 2010 - 05:45 AM

Bác test thử code trên của em đã hoàn thành rồi đấy. Kết thúc sớm vụ này thôi. Hề hề

Chưa kết thúc được đâu bạn ạ
Code của bạn vẫn không chạy được

Thank bác đã test giúp. Em đã fix lại rồi.


;; free lisp from cadviet.com

;; 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)
)
(princ (strcat "\n Chon nhom doi tuong thu : " (itoa sn)))
(while (setq ss (ssget))
(if ss (setq lss (append lss (list ss))))
(princ (strcat "\n Chon nhom doi tuong thu : " (itoa (setq sn (1+ sn))) " hoac an Enter de ket thuc"))
)
(taobo)
)

(defun taobo ()
(setq k 0)
(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
)
(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 list_area nil)
(while (< i (sslength list_pl))
(setq boname (ssname list_pl i))
(command "area" "o" boname)
(setq list_area (append (list (getvar "area")) list_area))
(if (and (eq (apply 'max list_area) (getvar "area")) (> (sslength list_pl) 1))
(setq delname boname)
)
(setq i (1+ i))
)
(if (> (sslength list_pl) 1)
(progn
(command "erase" delname "")
(setq list_pl (ssdel delname list_pl))
)
)
(setq list_plmoi (append (list list_pl) list_plmoi)
)
)
(defun c:tdd ()
(inittdd)
(command "undo" "be")
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
k 0 id 1
ptlst nil
dlst1 nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq h 0)
(while (< h (length list_plmoi))
(setq list_pl (nth h list_plmoi))
(setq p 0)
(while (< p (sslength list_pl))
(setq name (ssname list_pl 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))
(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 h (1+ h))
)
(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
)

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 độ.......

Tue_NV có góp ý như thế này :
4. Việc xử lý các nhóm khác nhau, có thể xử dụng phuơng án này :
--- Chọn đối tượng độc lập theo từng nhóm -> Cho vào 1 List. Duyệt qua tập chọn trong List đó và xử lý. :cheers:


  • 0

#2223 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 October 2010 - 09:27 AM

Anh viết như xiếc vậy, hay thật. E cám ơn anh nhiều. 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.

Nó bị dậy nè , đây là nguyên văn dòng báo:

" Command: DTM
CADViet.com © 2007
Vao diem can tinh dien tich: .boundary
Specify internal point or [Advanced options]: A
Enter an option [Boundary set/Island detection/Object type]: B
Specify candidate set for boundary [New/Everything] : E Selecting
everything visible...
Analyzing the selected data...

Enter an option [Boundary set/Island detection/Object type]: I
Do you want island detection? [Yes/No] : Y
Enter an option [Boundary set/Island detection/Object type]:
Specify internal point or [Advanced options]:
Valid hatch boundary not found.
Specify internal point or [Advanced options]:
Command: "

Đâ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) "

Ah, em muốn ghi luôn cả kết quả chia lên bản vẽ như lisp dtm vậy. Anh Tú chỉnh lại giúp e nha. Em cám ơn anh.

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.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2224 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 14 October 2010 - 09:45 AM

Anh viết như xiếc vậy, hay thật. E cám ơn anh nhiều.
Ah, em muốn ghi luôn cả kết quả chia lên bản vẽ như lisp dtm vậy. Anh Tú chỉnh lại giúp e nha. Em cám ơn anh.

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

  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2225 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 October 2010 - 10:15 AM

Bác test thử code trên của em đã hoàn thành rồi đấy. Kết thúc sớm vụ này thôi. Hề hề

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.c...files/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.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2226 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 14 October 2010 - 11:26 AM

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.c...files/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.
  • 2
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2227 w1nDream

w1nDream

    biết lệnh ddedit

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

Đã gửi 14 October 2010 - 11:40 AM

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.c.../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:
  • 0
__Tâm tựa lưu thủY__
Vi nhân nan

#2228 hugo75

hugo75

    biết vẽ polygon

  • Members
  • PipPip
  • 72 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 14 October 2010 - 01:55 PM

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.c...es/3/acad_1.lsp
  • 0

#2229 w1nDream

w1nDream

    biết lệnh ddedit

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

Đã gửi 14 October 2010 - 02:19 PM

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.c...es/3/acad_1.lsp


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

http://www.cadviet.c.../3/acad_1_1.lsp
  • 1
__Tâm tựa lưu thủY__
Vi nhân nan

#2230 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 14 October 2010 - 02:36 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#2231 hugo75

hugo75

    biết vẽ polygon

  • Members
  • PipPip
  • 72 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 14 October 2010 - 03:27 PM

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

http://www.cadviet.c.../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
  • 0

#2232 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 14 October 2010 - 06:31 PM

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.
  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2233 tamkt

tamkt

    biết vẽ ellipse

  • Members
  • PipPip
  • 51 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 14 October 2010 - 09:04 PM

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

#2234 tamkt

tamkt

    biết vẽ ellipse

  • Members
  • PipPip
  • 51 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 14 October 2010 - 09:28 PM

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

#2235 nguyentuyen6

nguyentuyen6

    biết lệnh chamfer

  • Advance Member
  • PipPipPipPip
  • 213 Bài viết
Điểm đánh giá: 124 (tàm tạm)

Đã gửi 14 October 2010 - 10:08 PM

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

Lisp In bản vẽ hàng loạt:
http://www.cadviet.c...ndpost&p=139860


#2236 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 14 October 2010 - 10:52 PM

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

  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2237 tamkt

tamkt

    biết vẽ ellipse

  • Members
  • PipPip
  • 51 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 14 October 2010 - 11:24 PM

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

#2238 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 15 October 2010 - 07:52 AM

.......
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 "")
  • 2

#2239 w1nDream

w1nDream

    biết lệnh ddedit

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

Đã gửi 15 October 2010 - 10:05 AM

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:
  • 0
__Tâm tựa lưu thủY__
Vi nhân nan

#2240 hugo75

hugo75

    biết vẽ polygon

  • Members
  • PipPip
  • 72 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 15 October 2010 - 12:28 PM

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

http://www.cadviet.c.../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.
  • 0