[分享]一個能顯示面積及長度的LISP程式

1.新增一個文字文件(.txt),貼上以下內容

代碼:

(defun C:am (/ ss l i totalarea ename obj entarea)
  (if (setq ss (ssget))
    (progn
      (vl-load-com)
      (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
      (setq l (sslength ss) i 0 totalarea 0 totlength 0)
      (repeat l
        (setq ename (ssname ss i))
        (setq obj (vlax-ename->vla-object ename))
  (if (vlax-property-available-p obj "area")
          (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
        )
  (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    (setq totlength (+ totlength (ml-length ename)))
    (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
  )
        (setq i (1+ i))
      )
      (setq text1 (strcat "總面積為 : " (rtos totalarea 2 4) "平方公分")
      text2 (strcat "總長度為 : " (rtos totlength 2 4) "公分")
      )
      (if (setq insertpt (getpoint "\n請輸入文字插入點: "))
    (if (setq height (GETREAL "\n請輸入文字高度:"))
    (setq insertp1 (vlax-3d-point insertpt)
  insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))
          textobj1 (vla-addtext modelspace text1 insertp1 height)
  textobj2 (vla-addtext modelspace text2 insertp2 height)
    )
  )
      )
    )
  )
)
(defun ml-length (ename / j d ptlist)
  (foreach n (entget ename)
    (if (= (car n) 11)
      (setq ptlist (cons (cdr n) ptlist))
    )
  )
  (reverse ptlist)
  (setq j 0 d 0)
  (repeat (1- (length ptlist))
    (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    (setq j (1+ j))
  )
  d
)

2.在將該文件副檔名改為(.lsp) (檔名:am.lsp)
3.開啟Autocad工具列中的「載入/卸載應用程式」對話方塊或者執行[appload]
4.選擇該文件位置後載入
5.在指令列key入"am"後,選擇你要的線或面方可使用(但不能選擇圖塊喔)
PS:這是一位建築師給我的LISP
ps:好東西與好朋友分享!!

---

謝謝程式分享及說明~< 積分 +1>

[公告]關於團隊成員的回文及貢獻

請問是您自己寫的嗎，如果不是請註明出處。
謝謝~

PS:這個程式只適合公分，其他單位要自己換算~

「教學」載入LISP應用程式 APPLOAD指令
http://autocad.bestoforum.net/forum-f7/topic-t111.htm

Tiger&蘋果爸 寫到:請問是您自己寫的嗎，如果不是請註明出處。
謝謝~

PS:這個程式只適合公分，其他單位要自己換算~

「教學」載入LISP應用程式 APPLOAD指令
http://autocad.bestoforum.net/forum-f7/topic-t111.htm

PS:這是一位建築師給我的LISP謝謝

bruce79 寫到:

Tiger&蘋果爸 寫到:請問是您自己寫的嗎，如果不是請註明出處。
謝謝~

PS:這個程式只適合公分，其他單位要自己換算~

「教學」載入LISP應用程式 APPLOAD指令
http://autocad.bestoforum.net/forum-f7/topic-t111.htm

PS:這是一位建築師給我的LISP謝謝

OK~了解!!
所以一般建築師事務所使用的單位為公分!

謝謝程式分享
lsP看看

Tiger&蘋果爸 寫到:
PS:這個程式只適合公分，其他單位要自己換算~

小小修改一下!就變成公釐mm

代碼:

(defun C:amm (/ ss l i totalarea ename obj entarea)
  (if (setq ss (ssget))
    (progn
      (vl-load-com)
      (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
      (setq l (sslength ss) i 0 totalarea 0 totlength 0)
      (repeat l
        (setq ename (ssname ss i))
        (setq obj (vlax-ename->vla-object ename))
  (if (vlax-property-available-p obj "area")
          (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
        )
  (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    (setq totlength (+ totlength (ml-length ename)))
    (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
  )
        (setq i (1+ i))
      )
      (setq text1 (strcat "總面積為 : " (rtos totalarea 2 4) "平方公釐")
      text2 (strcat "總長度為 : " (rtos totlength 2 4) "公釐(mm)")
      )
      (if (setq insertpt (getpoint "\n請輸入文字插入點: "))
    (if (setq height (GETREAL "\n請輸入文字高度:"))
    (setq insertp1 (vlax-3d-point insertpt)
  insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))
          textobj1 (vla-addtext modelspace text1 insertp1 height)
  textobj2 (vla-addtext modelspace text2 insertp2 height)
    )
  )
      )
    )
  )
)
(defun ml-length (ename / j d ptlist)
  (foreach n (entget ename)
    (if (= (car n) 11)
      (setq ptlist (cons (cdr n) ptlist))
    )
  )
  (reverse ptlist)
  (setq j 0 d 0)
  (repeat (1- (length ptlist))
    (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    (setq j (1+ j))
  )
  d
)

judyyai 寫到:

Tiger&蘋果爸 寫到:
PS:這個程式只適合公分，其他單位要自己換算~

小小修改一下!就變成公釐mm

代碼:

(defun C:amm (/ ss l i totalarea ename obj entarea)
  (if (setq ss (ssget))
    (progn
      (vl-load-com)
      (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
      (setq l (sslength ss) i 0 totalarea 0 totlength 0)
      (repeat l
        (setq ename (ssname ss i))
        (setq obj (vlax-ename->vla-object ename))
  (if (vlax-property-available-p obj "area")
          (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
        )
  (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    (setq totlength (+ totlength (ml-length ename)))
    (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
  )
        (setq i (1+ i))
      )
      (setq text1 (strcat "總面積為 : " (rtos totalarea 2 4) "平方公釐")
      text2 (strcat "總長度為 : " (rtos totlength 2 4) "公釐(mm)")
      )
      (if (setq insertpt (getpoint "\n請輸入文字插入點: "))
    (if (setq height (GETREAL "\n請輸入文字高度:"))
    (setq insertp1 (vlax-3d-point insertpt)
  insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))
          textobj1 (vla-addtext modelspace text1 insertp1 height)
  textobj2 (vla-addtext modelspace text2 insertp2 height)
    )
  )
      )
    )
  )
)
(defun ml-length (ename / j d ptlist)
  (foreach n (entget ename)
    (if (= (car n) 11)
      (setq ptlist (cons (cdr n) ptlist))
    )
  )
  (reverse ptlist)
  (setq j 0 d 0)
  (repeat (1- (length ptlist))
    (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    (setq j (1+ j))
  )
  d
)

謝謝JUDY熱心的修改!!

感謝分享!

感謝分享.....

(if (vlax-property-available-p obj "area")
這判斷式我在vba尚未找到,先用On Error Resume Next替代
附上相對應vba碼

代碼:

Const pi As Double = 3.14159265358979
Sub ts() '計算面積,長度
  Dim ss As AcadSelectionSet
  On Error Resume Next
    ThisDrawing.SelectionSets.Item("ss").Delete
  On Error GoTo 0
    Set ss = ThisDrawing.SelectionSets.Add("ss")
  ss.SelectOnScreen

Dim totalarea As Double
Dim totlength As Double

For Each ent In ss
    On Error Resume Next
    If IsError(ent.Area) Then MsgBox "此物件不含面積,也不是多重線" _
        Else: totalarea = ent.Area + totalarea
    On Error GoTo 0
  totlength = ent.Length + totlength
Next
totalarea = Format(totalarea, "##,##0.00")
totlength = Format(totlength, "##,##0.00")
text1 = "總面積為 : " & totalarea & " 平方公分"
text2 = "總長度為 : " & totlength & " 公分"

Dim insertp1 As Variant
Dim insertp2 As Variant
Dim Height As Double

insertp1 = ThisDrawing.Utility.GetPoint(, "選擇文字起點")
 On Error Resume Next
Height = ThisDrawing.Utility.GetReal("請輸入文字高度:")
  On Error GoTo 0
 If Height = 0 Then Height = 80
insertp2 = ThisDrawing.Utility.PolarPoint(insertp1, 1.5 * pi, 1.5 * Height)
Set textobj1 = ThisDrawing.ModelSpace.AddText(text1, insertp1, Height)
Set textobj2 = ThisDrawing.ModelSpace.AddText(text2, insertp2, Height)
End Sub

感謝分享~

趕快來試試看 謝囉　

工作上常要計算,謝謝哦.....

室內設計耶可以用呢～~感謝您!!

面積計算，蠻多行業都是需要的，感謝分享

目前工作急需使用
感謝無私的分享
感恩!!

不錯的分享，LISP是一個值得研究的內容，
正好看看內容來學習一些知識也是不著的！
感謝bruce79大大的分享，
同時也感謝Judyyai的貢獻！

感謝分享

這裏有可以量測長度及面積程式,
網址 http://tw.myblog.yahoo.com/rain-fall/archive?l=f&id=19

感謝bruce79提供程式.

經我測試,
如果選取封閉的複線時,
面積為0,
且長度不正確!!

計算長度的LISP我有,面積LISP我想看看!

自己不會寫
至少別人寫也要會用
謝謝大大.

我都是計算公尺，很少用到公分和公厘。

感謝大大分享

謝謝您的分享~
正好有這個需要~謝謝
也學習到原來CAD也可以像是寫程式依樣~輸入指令