Lisp diện tích hatch

[xuandat268 0]

Chào các anh
Trên diễn đàn đã có lisp tính diện tích hatch, nhưng chỉ áp dụng được với hatch có bao kín. Trên Property có hiển thi Area
Với hatch có bound hở, thì lisp không tính được. Nhờ anh em trợ giúp

[Duong Nhat Duy 388]

44 phút trước, xuandat268 đã nói:

Chào các anh
Trên diễn đàn đã có lisp tính diện tích hatch, nhưng chỉ áp dụng được với hatch có bao kín. Trên Property có hiển thi Area
Với hatch có bound hở, thì lisp không tính được. Nhờ anh em trợ giúp

Cái này mình sưu tầm: Lisp tính tổng diện tích Hatch (kể cả Hacth lỗi không có Area property), sau đó thông báo ra màn hình (chứ ko ghi ra text)

Nhưng cũng phải lưu ý rằng: đã là Hatch lỗi thì diện tích tính ra bao nhiêu cũng chỉ là do cách quy ước của người viết, chứ không có đáp án đúng nào ở đây cả.

Ví dụ hatch của 1 hình vuông bị khuyết 1 cạnh, thì quy ước là coi như hình vuông đó kín rồi tính S hình kín đó. Nhưng đó là trường hợp đơn giản, thực tế có rất nhiều các trường hợp phức tạp khác ví dụ Hatch chồng chéo nhiều đường bao, ... thì không có cách tính nào đúng ở đây cả, khi đó lisp nó tính ra bao nhiêu thì mình chấp nhận là bấy nhiêu thôi !

;Tinh dien tich Hatch loi
(defun c:aa1 ( / AREA AREA+ AREA_T ENT ENT_L FLAG I L_ENT N OBJ SS SS1 SS2 TYP)
  (setvar "CMDECHO" 0)
  (setvar "DIMZIN" 0)
  (if (and (setq ss (ssget (list (cons 0 "HATCH"))))
	   (setq area_t 0.0)
	   )
    (progn
      (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
      (repeat (setq i (sslength ss))
	(setq ent (ssname ss (setq i (1- i))))
	(setq obj (vlax-ename->vla-object ent))
	(if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq area (vlax-get obj 'area))))))
	  (progn
	    (setq ent_l (entlast))
	    (setq l_ent ent_l)
            (setq ss1 (ssadd))
            (setq area+ nil)
            (setq flag nil)
	    (command "_.-HATCHEDIT" ent "_B" "_P" "_N")
	    (while (setq ent_l (entnext ent_l))
	      (ssadd ent_l ss1)
	      )
	    (setq ent_l (entlast))
            (setq ss2 (ssadd))
	    (repeat (setq n (sslength ss1))
	      (setq ent (entget (ssname ss1 (setq n (1- n)))))
              (setq typ (cdr (assoc 0 ent)))
	      (if (not (wcmatch typ "*POLY*"))
		(setq flag T)
		)
	      )
	    (if flag
	      (command "_.PEDIT" "_M" ss1 "" "_Y" "_J" 0.01 "_C" "")
	      (command "_.PEDIT" "_M" ss1 "" "_J" 0.01 "_C" "")
	      )
	    (while (setq l_ent (entnext l_ent))
	      (ssadd l_ent ss2)
	      )
	    (repeat (setq n (sslength ss2))
	      (setq area (vlax-get (vlax-ename->vla-object (ssname ss2 (setq n (1- n)))) 'area))
              (setq area+ (cons area area+))
	      )
	    (setq area+ (vl-sort area+ '>))
	    (command "_erase" ss2 "")
	    (setq area (abs (eval (cons '- area+))))
            (setq area_t (+ area_t area))
	    )
	  (setq area_t (+ area_t area))
	  )
	)
      (command "REGEN")
      (princ (rtos area_t 2 (getvar "LUPREC")))
      (alert (rtos area_t 2 (getvar "LUPREC")))
      )
    )
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
  )

 

[xuandat268 0]

vâng, em cảm ơn anh nhé. Để em thử ạ