面积计算并统计(请帮忙修改)

香田里浪人

存在问题：1程序比较扎乱，不简练。2面积标注与统计（实际上是求和）要选2次。请求修改为一次选择即可完成面积标注与统计标注，谢谢！程序如下：
;;;面积计算并统计
(defun c:mjjstj(/ 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输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:")
TextIndex 1
)
    (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "a"));;;指定输出文件路径
  (write-line "编号\t面积(㎡)" f)
     (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE")))
(command "layer" "M" "计算面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "黑体" "0" "0.7" "0" "" "")
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
   (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 Textbh (itoa TextIndex) "=" (rtos (/ ObjArea 1)2 2) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
      )
(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1)2 2) ) f)
       (vla-put-alignment TextObj acAlignmentCenter)
       (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))   
    (setq TextIndex (1+ TextIndex))      
       )     
)
(close f)
(princ "面积标注完毕，要统计请选择统计对象，不统计请按esc")
  (if (setq ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
    (progn
      (vl-load-com)
      (setq l (sslength ss) k 0 tarea 0 )
      (repeat l
        (setq ename (ssname ss k))
        (setq obj (vlax-ename->vla-object ename))
        (if (vlax-property-available-p obj "area")
          (setq tarea (+ (vlax-get-property obj 'area) tarea))
        )
        (setq k (1+ k))
      )  

      (setq insPt0 (getpoint "\n请输入文字插入点: "))            
(setq tarea (/ tarea 1))
(setq bb (strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa l)"="(rtos tarea 2 2)"㎡"))
(command "_text" insPt0 TextHeight "" bb 0)
(princ )
     
    )

    (princ "\n未选择对象")
  )
  (setvar "cmdecho" 1)
  (prin1)
)

再见熊猫衣服

经过我的测试，这个插件不好用。
1，会自动生成mj模式的字体，没有该字体的会显示乱码
2，无法统计总面积
3，最终面积是平方毫米，不是平方米

综上，不建议下载。
就是这个，不建议下载。

zhangrunze

hao3ren 发表于 2014-5-9 17:33
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...

算了几次，这个单位是平方毫米~

hn10183051

改下就好了~
(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1e6)2 3) ) f)

hao3ren

自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ 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输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:")
TextIndex 1
)
    (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "a"));;;指定输出文件路径
  (write-line "编号\t面积(㎡)" f)
  (setq ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
(command "layer" "M" "计算面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "黑体" "0" "0.7" "0" "" "")
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
   (setq Selectionset (vla-get-activeselectionset AcadDoc))
   (setq tarea 0 )
   (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 Textbh (itoa TextIndex) "=" (rtos (/ ObjArea 1)2 2) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
      )
(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1)2 2) ) f)
       (vla-put-alignment TextObj acAlignmentCenter)
       (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
       (setq tarea (+ ObjArea tarea))
       (setq TextIndex (1+ TextIndex))      
       )     
)
(close f)
(setq l (sslength ss))
(setq insPt0 (getpoint "\n请输入文字插入点: "))            
(setq tarea (/ tarea 1))
(setq bb (strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa l)"="(rtos tarea 2 2)"㎡"))
(command "_text" insPt0 TextHeight "" bb 0)
  (setvar "cmdecho" 1)
  (prin1)
)

香田里浪人

hao3ren 发表于 2014-5-9 17:33
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...

谢谢！就是这样。满足要求。

flytoday

增加个从左到右从上到下的排序更好点

llsheng_73

(defun c:mjjstj(/ OBJLLPOINT OBJRUPOINT TEXTHEIGHT TEXTINDEX f ss e i obj l tarea)
  (vl-load-com)
  (setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
  (setq TextHeight (getdist "\n输入标注文字高度:")Textbh(getstring "\n输入编号前缀:")
        f(getfiled "指定输出文件路径" "" "txt" 1));;;指定输出文件路径
  (command "layer" "M" "计算面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
  (command "style" "tukou" "黑体" "0" "0.7" "0" "" "")
  (if f(progn
         (setq f(open f "a")i 0 TextIndex 1 tarea 0
               ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
         (write-line "编号\t面积(㎡)" f)
         (repeat(SSlength ss)
           (setq e(ssname ss i)i(1+ i)
                 Obj(vlax-ename->vla-object e))
           (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
           (setq l(cons(list(mapcar'(lambda(x y)(/ (+ x y)2))(vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
                            (vla-get-Area(vlax-ename->vla-object e)))l)))
         (foreach x(vl-sort l'(lambda(x y)(<(last x)(last y))))
           (write-line(setq txt(strcat Textbh(itoa TextIndex)"\t"(setq area(rtos(last x)2 2))))f)
           (entmake(list'(0 . "TEXT")'(8 . "计算面积")(cons 10 (car x))(cons 1 (STRCAT(vl-string-subst"=""\t"txt)"㎡"))
                        (CONS 40 TextHeight)'(7 . "tukou")(cons 11 (car x))'(72 . 1)))
           (setq tarea(+(atof area)tarea)
                 TextIndex(1+ TextIndex)))
         (close f)
         (entmake(list'(0 . "TEXT")'(8 . "计算面积")(cons 10 (setq e(getpoint"\n请输入文字插入点: ")))
                      (cons 1(strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa TextIndex)"="(rtos tarea 2 2)"㎡"))
                        (CONS 40 TextHeight)'(7 . "tukou")(cons 11 e)'(72 . 1)))
         )
    (alert"没有选择文件"))
  (princ)
  )

长风（尚品）

能不能再修改一下：1、将小数点向左移6位，小数位只留2位呢？
                  2、取消前辍
                  3、输出设一个开关，需要则输出，不需要则不输出

长风（尚品）

hao3ren 发表于 2014-5-9 17:33
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...

能不能再修改一下：1、将小数点向左移6位，小数位只留2位呢？
                  2、取消前辍
                  3、输出设一个开关，需要则输出，不需要则不输出

香田里浪人

llsheng_73 发表于 2014-5-9 22:23
(defun c:mjjstj(/ OBJLLPOINT OBJRUPOINT TEXTHEIGHT TEXTINDEX f ss e i obj l tarea)
  (vl-load-com)
...

程序中   (cons 1(strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa TextIndex)"="(rtos tarea 2 2)"㎡"))
这句中的(itoa TextIndex)恐怕应该改为(itoa i)，不然，统计项数目与实际不相符。

bai2000

能不能再修改一下：1、将小数点向左移6位，小数位只留2位呢？
                  2、取消前辍
                  3、输出设一个开关，需要则输出，不需要则不输出

情迷法兰西0

谢谢答主，请收下我的膝盖