面积计算并统计(请帮忙修改)
存在问题：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，最终面积是平方毫米，不是平方米
综上，不建议下载。
就是这个，不建议下载。
hao3ren 发表于 2014-5-9 17:33
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...
算了几次，这个单位是平方毫米~ 改下就好了~
(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1e6)2 3) ) f) 自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(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 static/image/common/back.gif
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...
谢谢！就是这样。满足要求。 增加个从左到右从上到下的排序更好点 (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 static/image/common/back.gif
自己修改修改啊，看你求了那么多帖子
我程序也不会写，大概改了下
(defun c:mjjstj(/ ACADDOC ACADSPC OB ...
能不能再修改一下：1、将小数点向左移6位，小数位只留2位呢？
2、取消前辍
3、输出设一个开关，需要则输出，不需要则不输出 llsheng_73 发表于 2014-5-9 22:23 static/image/common/back.gif
(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)，不然，统计项数目与实际不相符。 能不能再修改一下：1、将小数点向左移6位，小数位只留2位呢？
2、取消前辍
3、输出设一个开关，需要则输出，不需要则不输出 谢谢答主，请收下我的膝盖
页:
[1]
2