Đến nội dung


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

[Đã xong] Lisp thống kê diện tích Hatch theo Layer


  • Please log in to reply
81 replies to this topic

#1 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 08 June 2011 - 11:19 AM

Chào các anh em!
Mình làm bên thiết kế cảnh quan, thường tính diện tích vật liệu sử dụng lớp Hatch (ví dụ diện tích thảm cỏ, diện tích thảm hoa a, thảm hoa B...)
Công việc rất mất thời gian, nhất là vừa tính diện tích vừa ghi kèm chú thích (Vd Cỏ lông heo (50m2), Hoa mười giờ (20m2)...)
Do đó mình rất mong muốn giá như có lisp thực hiện được việc này thì hay biết mấy:
- Tính diện tích và tổng diện tích các mảng hatch
- Ghi tên và diện tích ra text, vd Cỏ lông heo: 50m2 (tên là tên layer chứa lớp hatch đó, nếu nhiều mảng hatch khác layer thì ghi Noname chẳng hạn). Đơn vị sử dụng là m2
Mong các anh em giúp đỡ!
  • 0

#2 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 08 June 2011 - 03:44 PM

Chào các anh em!
Mình làm bên thiết kế cảnh quan, thường tính diện tích vật liệu sử dụng lớp Hatch (ví dụ diện tích thảm cỏ, diện tích thảm hoa a, thảm hoa B...)
Công việc rất mất thời gian, nhất là vừa tính diện tích vừa ghi kèm chú thích (Vd Cỏ lông heo (50m2), Hoa mười giờ (20m2)...)
Do đó mình rất mong muốn giá như có lisp thực hiện được việc này thì hay biết mấy:
- Tính diện tích và tổng diện tích các mảng hatch
- Ghi tên và diện tích ra text, vd Cỏ lông heo: 50m2 (tên là tên layer chứa lớp hatch đó, nếu nhiều mảng hatch khác layer thì ghi Noname chẳng hạn). Đơn vị sử dụng là m2
Mong các anh em giúp đỡ!

Nhắc bạn Hoangvulandscape,
Bạn không được phép post cùng một nội dung trên nhiều topic khác nhau. Nếu lần sau bạn còn vi phạm sẽ bị xóa toàn bộ các bài post có liên quan đó. lần này mình giúp bạn xóa các bài thừa, nhưng lần sau sẽ không như vậy nữa.
Bạn nên gửi một bản vẽ trình bày cụ thể cái bạn đã có, cái bạn muốn có để mọi người suy nghĩ bạn nhé.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#3 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 08 June 2011 - 04:47 PM

Nhắc bạn Hoangvulandscape,
Bạn không được phép post cùng một nội dung trên nhiều topic khác nhau. Nếu lần sau bạn còn vi phạm sẽ bị xóa toàn bộ các bài post có liên quan đó. lần này mình giúp bạn xóa các bài thừa, nhưng lần sau sẽ không như vậy nữa.
Bạn nên gửi một bản vẽ trình bày cụ thể cái bạn đã có, cái bạn muốn có để mọi người suy nghĩ bạn nhé.


Xin lỗi, mình không cố ý. Theo yêu cầu của bạn mình gởi kèm 1 bản vẽ để bạn có thể hình dung
http://www.mediafire...u9t5n0wdi9xchs1
  • 0

#4 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 09 June 2011 - 12:13 PM

Xin lỗi, mình không cố ý. Theo yêu cầu của bạn mình gởi kèm 1 bản vẽ để bạn có thể hình dung
http://www.mediafire...u9t5n0wdi9xchs1

Hề hề hề,
Chào bạn Hoangvulandscape, mình đã xem bản vẽ bạn gửi. Tuy nhiên có một vấn đề như sau:
Các vùng hatch của bạn sau khi hatch đã bị xóa đi các đường bao, vì vậy ở một số vùng hatch việc lấy boundary của nó không được bạn ạ. Và do không lấy được boundary nên việc lấy diện tích cũng chưa được.
Vì thế bạn hãy gửi cái bản vẽ mới hatch xong và chưa bị xóa đi cái boundary của vùng hatch. Như vậy mới có thể giúp bạn được. Việc tạo lại boundary của vùng hatch trên diễn đàn cũng đã có đề cập tới, nhưng chưa có giải pháp tối ưu bạn ạ, nhất là đối với những vùng hatch quá lớn như của bạn.
rất mong bạn hiểu và thông cảm với khó khăn của người viết lisp. Từ đó bạn có thể có những giải pháp tốt hơn cho công việc. (tỷ như sau khi hatch xong thì sử dụng lisp luôn, như vậy việc lấy đường bao của vùng hatch sẽ không bị khó khăn nữa)
Hề hề hề, chúc bạn vui.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#5 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 10 June 2011 - 09:49 AM

Hề hề hề,
Chào bạn Hoangvulandscape, mình đã xem bản vẽ bạn gửi. Tuy nhiên có một vấn đề như sau:
Các vùng hatch của bạn sau khi hatch đã bị xóa đi các đường bao, vì vậy ở một số vùng hatch việc lấy boundary của nó không được bạn ạ. Và do không lấy được boundary nên việc lấy diện tích cũng chưa được.
Vì thế bạn hãy gửi cái bản vẽ mới hatch xong và chưa bị xóa đi cái boundary của vùng hatch. Như vậy mới có thể giúp bạn được. Việc tạo lại boundary của vùng hatch trên diễn đàn cũng đã có đề cập tới, nhưng chưa có giải pháp tối ưu bạn ạ, nhất là đối với những vùng hatch quá lớn như của bạn.
rất mong bạn hiểu và thông cảm với khó khăn của người viết lisp. Từ đó bạn có thể có những giải pháp tốt hơn cho công việc. (tỷ như sau khi hatch xong thì sử dụng lisp luôn, như vậy việc lấy đường bao của vùng hatch sẽ không bị khó khăn nữa)
Hề hề hề, chúc bạn vui.


Cảm ơn góp ý của anh Bình. Thật ra mình cũng hatch từ đường bao, sau đó xóa đi, vì để nhiều đường bao rất rườm bản vẽ.
Vậy Anh có thể giúp em tạo lisp với yêu cầu như cũ nhưng tính bằng đường bao ko.
Và với đường bao có chứa Spline có tính dc ko?
Cảm ơn anh. Mong sớm hồi âm.
  • 0

#6 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 10 June 2011 - 11:19 AM

Cảm ơn góp ý của anh Bình. Thật ra mình cũng hatch từ đường bao, sau đó xóa đi, vì để nhiều đường bao rất rườm bản vẽ.
Vậy Anh có thể giúp em tạo lisp với yêu cầu như cũ nhưng tính bằng đường bao ko.
Và với đường bao có chứa Spline có tính dc ko?
Cảm ơn anh. Mong sớm hồi âm.

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình thường
(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
(vl-load-com)
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lay (vla-get-layer e) ar (vla-get-area e))
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))) )
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
tl 0.000001
pt (getpoint "\nDiem dat Bang :" )
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(foreach e lst
(vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
(vla-addtext msp
(strcat (rtos (* (cdr e) tl) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
(setq pt (polar pt (/ pi -2) (* 1.5 txtsiz))) ) )
(alert "Khong chon duoc Hatch.") )
(princ))
Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.
  • 2

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


#7 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 10 June 2011 - 12:24 PM

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình thường

(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
(vl-load-com)
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lay (vla-get-layer e) ar (vla-get-area e))
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))) )
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
tl 0.000001
pt (getpoint "\nDiem dat Bang :" )
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(foreach e lst
(vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
(vla-addtext msp
(strcat (rtos (* (cdr e) tl) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
(setq pt (polar pt (/ pi -2) (* 1.5 txtsiz))) ) )
(alert "Khong chon duoc Hatch.") )
(princ))
Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.

Từ Cad 2006, Hatch mới có thuộc tính Area.

Bạn nên kiểm tra đ/kiện này truoc khi quyết định đi tiếp ...
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
...
))

  • 1

#8 3d.decor

3d.decor

    biết vẽ arc

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

Đã gửi 10 June 2011 - 12:49 PM

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình thường

(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
(vl-load-com)
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lay (vla-get-layer e) ar (vla-get-area e))
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))) )
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
tl 0.000001
pt (getpoint "\nDiem dat Bang :" )
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(foreach e lst
(vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
(vla-addtext msp
(strcat (rtos (* (cdr e) tl) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
(setq pt (polar pt (/ pi -2) (* 1.5 txtsiz))) ) )
(alert "Khong chon duoc Hatch.") )
(princ))
Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.

lỗi rồi pro ơi
Diem dat Bang :; error: Automation Error. Invalid input
  • 0

#9 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 10 June 2011 - 01:59 PM

Cảm ơn góp ý của anh Bình. Thật ra mình cũng hatch từ đường bao, sau đó xóa đi, vì để nhiều đường bao rất rườm bản vẽ.
Vậy Anh có thể giúp em tạo lisp với yêu cầu như cũ nhưng tính bằng đường bao ko.
Và với đường bao có chứa Spline có tính dc ko?
Cảm ơn anh. Mong sớm hồi âm.

Hề hề hề,
Chào bạn Hoangvulandscape,
Với yêu cầu của bạn, nếu đường bao vùng hatch vẫn còn thì có nhẽ là không quá khó. Có thể làm được kể cả trường hợp đường bao có chứa spline. Bạn hãy chờ chút xíu để mình thử coi sao nhé.
Hề hề hề,
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#10 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 10 June 2011 - 02:56 PM

............
Trong bản vẽ bạn Hoangvu post, có hatch thuộc Layer hatch không lấy được diện tích nên sinh ra lỗi trên

Dùng hàm vl-catch-all-error-p để kiểm tra xem có phát sinh lỗi khi lấy thuộc tính nào đó.
Hạn chế của vl-catch-all-error-p là làm chậm tiến trình, tuy nhiên trong t/hợp này "chậm mà chắc".
(defun getArea (e)
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area(list e))))
(vla-get-area e)
0))

  • 1

#11 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 10 June 2011 - 03:18 PM

Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.


Từ Cad 2006, Hatch mới có thuộc tính Area.

Bạn nên kiểm tra đ/kiện này truoc khi quyết định đi tiếp ...
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
...
))

Dùng hàm vl-catch-all-error-p để kiểm tra xem có phát sinh lỗi khi lấy thuộc tính nào đó.
Hạn chế của vl-catch-all-error-p là làm chậm tiến trình, tuy nhiên trong t/hợp này "chậm mà chắc".

(defun getArea (e)
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area(list e))))
(vla-get-area e)
0))


(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (* 0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ "\n Co doi tuong Hatch khong lay duoc Dien tich. Da Highlight")
(redraw (vlax-vla-object->ename e) 3)
)
)
(setq lay (vlax-get-property e 'Layer))
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))))
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
pt (getpoint "\nDiem dat Bang :" )
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(foreach e lst
(vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
(vla-addtext msp
(strcat (rtos (cdr e) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
(setq pt (polar pt (/ pi -2) (* 1.5 txtsiz))) ) )
(alert "Khong chon duoc Hatch."))
)
(alert "Phien ban CAD khong ho tro tinh dien tich Hatch.")
)
(princ))
(defun st-ss->ent (ss / n e l)
(setq n -1)
(while (setq e (ssname ss (setq n (1+ n))))
(setq l (cons e l))
)
)

lỗi rồi pro ơi
Diem dat Bang :; error: Automation Error. Invalid input


Trong bản vẽ bạn Hoangvu post, có hatch thuộc Layer hatch không lấy được diện tích nên sinh ra lỗi trên.
Đã sửa theo gợi ý bác gia_bach
  • 1

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


#12 duy782006

duy782006

    PHẠM QUỐC DUY

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

Đã gửi 10 June 2011 - 03:42 PM

Trong bản vẽ bạn Hoangvu post, có hatch thuộc Layer hatch không lấy được diện tích nên sinh ra lỗi trên.
Đã sửa theo gợi ý bác gia_bach

Hatch là thằng trời ơi nhất lúc lấy được diện tích lúc không rất chi làm mệt mà ko hiều nguyên nhân. Mình viết lisp tính tổng diện tích các hatch chọn nhưng bị này nên nản = bỏ.
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#13 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 10 June 2011 - 03:46 PM

Cảm ơn các bạn rất nhiều!
Đã rất hay rồi, tuy nhiên cột tiêu đề (ví dụ CỎ) và cột diện tích là 2 text khác nhau do đó khoảng hở không linh động và phù hợp được. Giá như có thể gộp nó thành 1 text duy nhất thì hay quá. Hơn nữa nên định dạng theo kiểu: Cỏ: 10m2 hoặc Cỏ (10m2)thì hay hơn.
Mình không biết về lisp nên có thể có những yêu cầu không khả thi, mong các bạn thông cảm. Mình thấy đây là một lisp hay và có rất nhiều ứng dụng trong bản vẽ kỹ thuật, mong các bạn giúp đỡ.
Chân thành cảm ơn!
  • 0

#14 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 10 June 2011 - 03:57 PM

Cảm ơn các bạn rất nhiều!
Đã rất hay rồi, tuy nhiên cột tiêu đề (ví dụ CỎ) và cột diện tích là 2 text khác nhau do đó khoảng hở không linh động và phù hợp được. Giá như có thể gộp nó thành 1 text duy nhất thì hay quá. Hơn nữa nên định dạng theo kiểu: Cỏ: 10m2 hoặc Cỏ (10m2)thì hay hơn.
Mình không biết về lisp nên có thể có những yêu cầu không khả thi, mong các bạn thông cảm. Mình thấy đây là một lisp hay và có rất nhiều ứng dụng trong bản vẽ kỹ thuật, mong các bạn giúp đỡ.
Chân thành cảm ơn!

Hề hề hề,
Vậy là mình thành trâu chậm rồi. Các bác khác nhanh tay hơn. Dù sao đã trót thì phải trét nên mình cứ post cái mình đã làm để bạn xài thử và cho ý kiến nhé.

(defun c:dth ( / dt pt ten old new p1 p2 )
(vl-load-com)
(command "undo" "be")
(setq dt (entsel "\n Pick chon hatch can tinh dien tich"))
(while dt
(while (/= (cdr (assoc 0 (entget (car dt)))) "HATCH")
(setq dt nil)
(alert "\n Doi tuong chon khong phai la hatch. Hay chon lai. Pick dung doi tuong hatch.")
(setq dt (entsel))
)
(setq pt (cadr dt)
ten (cdr (assoc 8 (entget (car dt))))
old (entlast)
)
(command "boundary" pt "" "")
(setq new (entlast))
(if (not (eq old new))
(progn
(command "area" "O" new "" "")
(setq dtch (/ (getvar "area") 1000000))
)
)
(command "erase" new "")
(setq p1 (getpoint "\n Chon diem dat ten vung"))
(command "TEXT" p1 2 0 ten )
(setq p2 (getpoint "\n Chon diem dat dien tich vung"))
(command "TEXT" p2 2 0 (strcat (rtos dtch 2 6) " M2" ))
(setq dt (entsel " \n Chon hatch can tinh dien tich tiep theo"))
)
(command "undo" "e")
(princ)
)

Với lisp này bạn tùy ý chọn vị trí đặt text sao cho đẹp cái ý của bạn.
Hề hề hề,....
Nếu bạn muốn gộp hai text trên thành một text thì bạn làm như sau:
Thay đoạn code:
(command "TEXT" p1 2 0 ten )
(setq p2 (getpoint "\n Chon diem dat dien tich vung"))
(command "TEXT" p2 2 0 (strcat (rtos dtch 2 6) " M2" ))

thành dòng code sau:
(command "TEXT" p1 2 0 (strcat ten ": " (rtos dtch 2 6) " M2"))
Chúc bạn vui
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#15 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 10 June 2011 - 09:53 PM

Cảm ơn các bạn rất nhiều!
Đã rất hay rồi, tuy nhiên cột tiêu đề (ví dụ CỎ) và cột diện tích là 2 text khác nhau do đó khoảng hở không linh động và phù hợp được. Giá như có thể gộp nó thành 1 text duy nhất thì hay quá. Hơn nữa nên định dạng theo kiểu: Cỏ: 10m2 hoặc Cỏ (10m2)thì hay hơn.
Mình không biết về lisp nên có thể có những yêu cầu không khả thi, mong các bạn thông cảm. Mình thấy đây là một lisp hay và có rất nhiều ứng dụng trong bản vẽ kỹ thuật, mong các bạn giúp đỡ.
Chân thành cảm ơn!

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại chỗ tùy ý để bạn tiện ghi chú

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(acet-sysvar-set (list "cmdecho" 0))
(grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
(Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch : ")
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
(setq lay (vlax-get-property e 'Layer))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (* 0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))))
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
(while (setq e (nth (setq i (1+ i)) lst))
(vla-addtext msp (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") (vlax-3d-point '(0 0 0)) txtsiz)
(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
(command ".move" (entlast) "" '(0 0 0) pt)
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
(alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
(acet-sysvar-restore)(princ))
(defun st-ss->ent (ss / n e l)
(setq n -1)
(while (setq e (ssname ss (setq n (1+ n))))
(setq l (cons e l))
)
)

  • 2

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


#16 3d.decor

3d.decor

    biết vẽ arc

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

Đã gửi 11 June 2011 - 08:12 AM

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại chỗ tùy ý để bạn tiện ghi chú

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(acet-sysvar-set (list "cmdecho" 0))
(grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
(Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch : ")
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
(setq lay (vlax-get-property e 'Layer))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (* 0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))))
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
(while (setq e (nth (setq i (1+ i)) lst))
(vla-addtext msp (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") (vlax-3d-point '(0 0 0)) txtsiz)
(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
(command ".move" (entlast) "" '(0 0 0) pt)
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
(alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
(acet-sysvar-restore)(princ))
(defun st-ss->ent (ss / n e l)
(setq n -1)
(while (setq e (ssname ss (setq n (1+ n))))
(setq l (cons e l))
)
)


không hiểu sao mình dùng vẫn lỗi pro à
Select objects: ; error: Automation Error. Invalid input
mình dùng cad 2012
  • 0

#17 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 June 2011 - 08:40 AM

không hiểu sao mình dùng vẫn lỗi pro à
Select objects: ; error: Automation Error. Invalid input
mình dùng cad 2012

Mình chịu rồi :mellow:
  • 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


#18 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 11 June 2011 - 09:55 AM

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại chỗ tùy ý để bạn tiện ghi chú

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(acet-sysvar-set (list "cmdecho" 0))
(grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
(Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch : ")
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
(setq lay (vlax-get-property e 'Layer))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (* 0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))))
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
(while (setq e (nth (setq i (1+ i)) lst))
(vla-addtext msp (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") (vlax-3d-point '(0 0 0)) txtsiz)
(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
(command ".move" (entlast) "" '(0 0 0) pt)
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
(alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
(acet-sysvar-restore)(princ))
(defun st-ss->ent (ss / n e l)
(setq n -1)
(while (setq e (ssname ss (setq n (1+ n))))
(setq l (cons e l))
)
)


Cảm ơn bạn Ketxu! Lisp này chạy rất tốt. Chân thành cảm ơn bạn!
  • 0

#19 Hoangvulandscape

Hoangvulandscape

    biết zoom

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

Đã gửi 11 June 2011 - 10:10 AM

Mình chịu rồi :mellow:


Mình biết rồi. Lỗi này là do miếng Hatch của bạn bị lỗi ko có giá trị diện tích (bạn coi trong mục Properties ấy). Nếu trong Properties mà ko có diện tích thì sẽ bị lỗi trên
  • 0

#20 3d.decor

3d.decor

    biết vẽ arc

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

Đã gửi 11 June 2011 - 10:22 AM

Mình biết rồi. Lỗi này là do miếng Hatch của bạn bị lỗi ko có giá trị diện tích (bạn coi trong mục Properties ấy). Nếu trong Properties mà ko có diện tích thì sẽ bị lỗi trên

có Area mà vậy khắc phục thế nào pro nhỉ
mình trót dùng cad 2012 mất rồi
thôi dùng tạm lisp DT vậy
  • 0