cxs259 发表于 2011-7-20 21:04:09

（求助）能否把下面程序的面积单位除以10六次方改为平方米，谢谢！

(defun c:ttt(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
(vl-load-com)
(setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "TILEMODE") 1)(setq AcadSpc (vla-get-modelspace AcadDoc))(setq AcadSpc (vla-get-paperspace AcadDoc)))
(setq TextHeight (getdist "\n输入标注文字高度:")
TextIndex (getint "\n输入起始编号:")
)
(ssget '((0 . "LWPOLYLINE")))
(setq Selectionset (vla-get-activeselectionset AcadDoc))
(if (and TextHeight Selectionset TextIndex)
    (vlax-for Obj Selectionset
      (setq ObjArea (vla-get-area obj)
   ObjLlPoint nil
   ObjRuPoint nil
   )
      (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
      (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
   TextObj (vla-addtext AcadSpc (strcat (itoa TextIndex) "号面积=" (rtos ObjArea) "平方米") (vlax-3d-point TextBasePoint) TextHeight)
   )
      (vla-put-alignment TextObj acAlignmentCenter)
      (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
      (setq TextIndex (1+ TextIndex))      
      )
    )
)

祥子 发表于 2011-7-20 22:08:10

回复 cxs259 的帖子

;红色部份
(defun c:ttt(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
(vl-load-com)
(setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "TILEMODE") 1)(setq AcadSpc (vla-get-modelspace AcadDoc))(setq AcadSpc (vla-get-paperspace AcadDoc)))
(setq TextHeight (getdist "\n输入标注文字高度:")
TextIndex (getint "\n输入起始编号:")
)
(ssget '((0 . "LWPOLYLINE")))
(setq Selectionset (vla-get-activeselectionset AcadDoc))
(if (and TextHeight Selectionset TextIndex)
    (vlax-for Obj Selectionset
      (setq ObjArea (vla-get-area obj)
   ObjLlPoint nil
   ObjRuPoint nil
   )
      (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
      (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
   TextObj (vla-addtext AcadSpc (strcat (itoa TextIndex) "号面积=" (rtos (/ ObjArea 1000000.0 )) "平方米") (vlax-3d-point TextBasePoint) TextHeight)
   )
      (vla-put-alignment TextObj acAlignmentCenter)
      (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
      (setq TextIndex (1+ TextIndex))      
      )
    )
)

gbhsu 发表于 2011-7-20 22:11:17

本帖最后由 gbhsu 于 2011-7-20 22:14 编辑

(defun c:ttt(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
(vl-load-com)
(setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "TILEMODE") 1)(setq AcadSpc (vla-get-modelspace AcadDoc))(setq AcadSpc (vla-get-paperspace AcadDoc)))
(setq TextHeight (getdist "\n输入标注文字高度:")
TextIndex (getint "\n输入起始编号:")
)
(ssget '((0 . "LWPOLYLINE")))
(setq Selectionset (vla-get-activeselectionset AcadDoc))
(if (and TextHeight Selectionset TextIndex)
    (vlax-for Obj Selectionset
      (setq ObjArea (vla-get-area obj)
   ObjLlPoint nil
   ObjRuPoint nil
   )
      (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
      (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
   TextObj (vla-addtext AcadSpc (strcat (itoa TextIndex) "号面积=" (rtos (/ ObjArea 100000)) "平方米") (vlax-3d-point TextBasePoint) TextHeight)
   )
      (vla-put-alignment TextObj acAlignmentCenter)
      (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
      (setq TextIndex (1+ TextIndex))      
      )
    )
)

gbhsu 发表于 2011-7-20 22:12:36

本帖最后由 gbhsu 于 2011-7-20 22:16 编辑

程式不错，值得学习！

cxs259 发表于 2011-8-3 09:22:39

首先谢谢祥子的解答！能否把下面程序的面积及周长的单位平方毫米/毫米，改成平方米/米，谢谢
面积与周长求和
(defun C:qqq (/ 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))
        ;;(vlax-dump-object obj T)
        (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 0) "平方豪米")
          text2 (strcat "总周长为: " (rtos totlength 2 0) "豪米")
      )
      (if (setq insertpt (getpoint "\n请输入文字插入点: "))
        (if (setq height (getdist "\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
)

大将 发表于 2012-11-1 10:34:44

好程序，顶！能否实现框选对象，自动标注？

香田里浪人 发表于 2013-5-1 15:23:47

大将 发表于 2012-11-1 10:34 static/image/common/back.gif
好程序，顶！能否实现框选对象，自动标注？

可以满足实现框选对象自动标注。

bai2000 发表于 2013-5-1 17:23:41

这个函数不知道，待老大

konoko 发表于 2013-5-8 22:27:54

手机复制代码不方便，留印明天下。谢谢

趣意人生 发表于 2022-4-14 22:00:53


好程序，顶！
页: [1]
查看完整版本: （求助）能否把下面程序的面积单位除以10六次方改为平方米，谢谢！