autolisp diện tích giống lệnh area nhưng có thêm mục ghi text ra luôn

[nguyen son hai 0]

trên diễn đàn có rất nhiều autolisp, nhưng vấn đề em gặp là không mấy khi sử dụng lisp tính diện tích bấm vào vùng kín (bao bới đường pline) hoặc không cần pline...em không biết về autolisp, nhờ các bác xem giúp cái autolisp tính diện tích như này ạ. 

 

lisp giống như lệnh area của cad, nhưng sau đo muốn ghi text ra màn hình cho dễ nhớ, không cần phải mở f2 lên để đọc, sau đó dùng lisp tổng diện tích các text... vì trên trắc ngang rất nhiều loại đào đắp.

 

các bác xen giúp e với ạ. thanks các anh chị

[altsun 5]

Bạn dùng lisp này nhé (đơn vị ghi diện tích là m2, nếu cần có thể chỉnh lại trong lisp)

(SS) Tinh dien tich lien tuc m2.LSP

[nguyen son hai 0]

không phải lisp này bác ơi. cái này là tính diện tích các vùng kín riêng biệt, ý em là trên trắc ngang có rất nhiều điểm, muốn tính diện tích tạo bở 1 vài điểm bất kỳ, ta bấm giống lệnh aa của acad ấy ạ. nhưng sau đó  có mục ghi ra nền chứ không phải xem ở    f2 ạ

[ngokiet 169]

Vào lúc 14/4/2020 tại 16:06, nguyen son hai đã nói:

không phải lisp này bác ơi. cái này là tính diện tích các vùng kín riêng biệt, ý em là trên trắc ngang có rất nhiều điểm, muốn tính diện tích tạo bở 1 vài điểm bất kỳ, ta bấm giống lệnh aa của acad ấy ạ. nhưng sau đó  có mục ghi ra nền chứ không phải xem ở    f2 ạ

Thử lisp này

(defun c:test2()
  (command "area")
  (while (not (zerop (getvar 'cmdactive)))
    (command pause))
  (command "_text" (getpoint "diem dat text") 10.0 "" (rtos (getvar 'area)) "")
  (princ))

 

[nguyen son hai 0]

Vào lúc 14/4/2020 tại 18:25, ngokiet đã nói:

Thử lisp này

• test2.lsp
  
• [✎]
   

(defun c:test2()
  (command "area")
  (while (not (zerop (getvar 'cmdactive)))
    (command pause))
  (command "_text" (getpoint "diem dat text") "" "" (rtos (getvar 'area)) "")
  (princ))

không thấy nó ghi kết quả ra màn hình bác ạ.  sau khi nó hiện ra "điểm đặt text" bấm vào thì ko hiện ra text trên màn hình và dòng command báo như này ạ

[Doan Van Ha 3.201]

Vào lúc 14/4/2020 tại 18:25, ngokiet đã nói:

Thử lisp này

• test2.lsp
  
• [✎]
   

(defun c:test2()
  (command "area")
  (while (not (zerop (getvar 'cmdactive)))
    (command pause))
  (command "_text" (getpoint "diem dat text") "" "" (rtos (getvar 'area)) "")
  (princ))

 

Sửa chút nữa chỗ Command Text: style có height = 0 và height /= 0

[nguyen son hai 0]

10 phút trước, Doan Van Ha đã nói:

Sửa chút nữa chỗ Command Text: style có height = 0 và height /= 0

em biết về lisp đâu bác. sửa như nào giúp em với ạ

[ngokiet 169]

44 phút trước, nguyen son hai đã nói:

em biết về lisp đâu bác. sửa như nào giúp em với ạ

Lười nên viết đơn giản. Nếu bạn viết 1 text trước đó rồi thì nó theo text cũ.

Mình không biết tỉ lệ vẽ bạn nên có sữa tại text cao là 10.0 bạn muốn thay đổi thì sửa lại. (sửa trên lisp cũ ở trên)

Còn text ghi ra theo unit mặc định. Nếu thích thì tự sửa.

Bác sài lisp thì nên nghiên cứu sơ mấy lệnh cơ bản để sửa lisp thích hợp với mình.

[thiep 365]

Lisp này chắc phù hợp ý của @nguyen hai son

(defun lstpoint (/ ptemp PT lstp)
    (setq lstp (list (setq PT (getpoint "\nPick the first point "))))
    (setq ptemp pt)
    (while (setq PT (getpoint ptemp "\nPick the next point "))
        (grdraw ptemp PT 8 1)
        (setq lstp (append lstp (list pt)))
        (setq ptemp pt)
    )
    lstp
)     
(defun SetClipBoardText	(text / htmlfile result) ; By XShrimp
  (if (= 'STR (type text))
    (progn
      (setq htmlfile (vlax-create-object "htmlfile")
	    result   (vlax-invoke
		       (vlax-get (vlax-get htmlfile 'ParentWindow)
				 'ClipBoardData
		       )
		       'SetData
		       "Text"
		       text
		     )
      )
      (vlax-release-object htmlfile)
      text
    )
  )
)
(defun GetArea (lst )
    (/ (apply
           '+
           (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                   lst
                   (cons (last lst) lst)
           )
       )
       2
    )
)
(defun c:getA (/)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 545))
    (SetClipBoardText (rtos (abs (GetArea (lstpoint)))))
    (command "_pasteclip")
    (acet-sysvar-restore)
    (redraw)
    (command "undo" "en")
    (princ "\nOk")
)