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

Tháng 6 8, 2011

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 đỡ!

Tháng 6 8, 2011

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

Tháng 6 8, 2011

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.com/download.php?u9t5n0wdi9xchs1

Tháng 6 9, 2011

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.com/download.php?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.

Tháng 6 10, 2011

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.

Tháng 6 10, 2011

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.

Tháng 6 10, 2011

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

...

))

Tháng 6 10, 2011

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

Tháng 6 10, 2011

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ề,

Tháng 6 10, 2011

............

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

Tháng 6 10, 2011

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

Tháng 6 10, 2011

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

Tháng 6 10, 2011

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!

Tháng 6 10, 2011

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

Tháng 6 10, 2011

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

Tháng 6 11, 2011

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

Tháng 6 11, 2011

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:

Tháng 6 11, 2011

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!

Tháng 6 11, 2011

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

Tháng 6 11, 2011

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

Tháng 6 11, 2011

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

Trong lisp up sau khi gặp Hatch bị lỗi thì chương trình sẽ Highlight và thông báo nó không tính được, chứ không còn thông báo lỗi giống lisp lúc đầu như bạn 3d.decor nói (bạn Hoangvu có thể kiểm tra phần Hatch thuộc layer hatch trong bản vẽ của bạn để thấy ), nên mình bó tay vì không biết CAD12 của bạn nó ương ở chỗ nào :)

Tháng 6 11, 2011

Cảm ơn bạn, đây thực sự là cái mình cần. Cảm ơn rất nhiều

Nhờ bạn kiểm tra lại xem, sao đôi lúc tính đúng, nhưng đôi lúc tính ko đúng (hình như diện tích bị giảm gần 1 nửa. Với lại chỉ cần 2 con số lẻ thôi và cho cỡ chữ lớn lên khoảng 10 lần dc ko

Hề hề hề,

Lisp nó hổng tính sai đâu. Có nhẽ việc nó cho kết quả sai là do trong vùng hatch của bạn có lẫn một vài đường chia cắt vùng nào đó mà bạn không chú ý đấy thôi.

Khi chạy lisp, bạn chú ý một chút sẽ thấy cái boundary nó xuất hiện một chút rồi mất. Hãy so sánh cái boundary này với vùng hatch của bạn để phát hiện ra đường chia cắt đó.

Việc bạn muốn text lớn gấp 10 lần và chỉ lấy hai chữ số lẻ rất đơn giản. Hãy thay dòng code (command "text" p1 2 0 (strcat ten ": " (rtos dtch 2 6) " M2")) thành (command "text" p1 20 0 (strcat ten ": " (rtos dtch 2 2) " M2")).

Chúc bạn vui.

Tháng 6 12, 2011

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

Chào bạn, lại làm phiền bạn nữa rồi. Không hiểu sao có một số file cad ko sử dụng dc lisp này: nó chỉ load tới lệnh bảo chọn Hatch rồi im luôn không chạy nữa. Mình gởi kèm file cho bạn kiểm giùm. Cảm ơn bạn!

link bản vẽ: http://www.mediafire.com/?j2xlcl9tzev6jma

Cảm ơn!

Tháng 6 12, 2011

Chào bạn, lại làm phiền bạn nữa rồi. Không hiểu sao có một số file cad ko sử dụng dc lisp này: nó chỉ load tới lệnh bảo chọn Hatch rồi im luôn không chạy nữa. Mình gởi kèm file cho bạn kiểm giùm. Cảm ơn bạn!

link bản vẽ: http://www.mediafire.com/?j2xlcl9tzev6jma

Cảm ơn!

Lại vấp chỗ add text rồi, hem bít sao nữa :( bạn thử dùng thằng này thay thế xem sao. Chú ý : tạo text theo style + height hiện thời, bạn nên chọn style trước nhé

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
;(mapcar '(lambda(x) (set x nil)) '(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)) 
       (wtxt_l (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") '(0 0 0))
(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))
 )
)
(defun wtxt_l(txt p / sty d h1 h2 wf h);;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")
d (tblsearch "style" sty)
h1 (cdr (assoc 40 d))
h2 (cdr (assoc 42 d))
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 1)(cons 11 p) (cons 1 txt) (cons 10 p))))

Tháng 6 13, 2011

Chào bạn, lại làm phiền bạn nữa rồi. Không hiểu sao có một số file cad ko sử dụng dc lisp này: nó chỉ load tới lệnh bảo chọn Hatch rồi im luôn không chạy nữa. Mình gởi kèm file cho bạn kiểm giùm. Cảm ơn bạn!

link bản vẽ: http://www.mediafire.com/?j2xlcl9tzev6jma

Cảm ơn!

Hề hề hề,

Có nhẽ không phải vậy đâu bạn ạ. Chẳng qua có thể là do cái bản vẽ của bạn có thằng hatch tương đối lớn, lại khá rậm rì rắc rối nên việc lọc cho hết các phần tử của mảng hatch cũng tối tăm mắt mũi nên thằng lisp nó mới lò dò lâu vậy thôi. Bạn cứ chịu khó chờ dăm phút đến vài tiếng là nó sẽ chạy xong ấy mà. Có điều nếu bạn thấy thương nó thì hãy thử tắt bớt đi một vài layer hổng có liên quan tới vùng hatch ấy coi sao. Có nhẽ lisp sẽ chạy nhanh hơn vài chục lần đấy bạn ạ.

Hề hề hề,.....

Đăng nhập

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

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

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.549

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

3d.decor 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.549

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

duy782006 1.542

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

3d.decor 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Hoangvulandscape 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

3d.decor 1