[求助]求助算面积程序？
各位老师，我想用ARX编一个标注面积的程序，对于任意多边形，只需点击即可标出面积，可否帮忙？我这里先谢谢了。我的信箱lihongyu2467@163.com 你要明确一点：你所说的任意多边形？是否包括各条边可以交叉的凹多边形？另外，点击即可标出面积，该多边形在图形中已经存在，对吗？ 再详细一点，就是说多边形已经在图形中画出，可以是多边形，或者是圆等等的集合，当然包括各条边可以交叉的凹多边形，也就是用pline线随意画一些交叉的闭合图形。 有vba写的面积计算程序，要不？ 与其自己写一个边界搜索算法，不如直接使用boundary命令 ；；；面积标注 hwt
(defun c:TP (/ k)
;(alert "\n请确定所要查询的区域是否闭合，否则结果会出错!")
(command "layer" "set" "TP" "")
(initget "Yes No")
(setq k
(getkword
"\n请选择：在图上标注面积 仅查寻面积(不标注)/<Y>:"
)
)
(cond
((= k "Yes") (ISCLOSE))
((= k "No") (ubzmj))
(T (ISCLOSE))
)
)
;;;判断区域是否闭合，然后创建面域
(defun ISCLOSE (/ pt os mj m zc table ent1 entnm1 entnm2)
(setq table (entget (entlast)))
(setq entnm1 (assoc -1 table))
(setq entnm1 (cdr entnm1))
(setq pt1 (getpoint "请在区域内任意一点")) ;取一点创建面域
(command "bpoly" pt1 "") ;创建面域
(setq ent1 (entlast))
(setq table (entget ent1))
(setq entnm2 (assoc -1 table))
(setq entnm2 (cdr entnm2))
(if (equal entnm1 entnm2) ;非T，区域没有闭合
((alert "区域没有封闭，无法进行面积计算，请检查！") ())
;如果已经闭合则执行以下程序
(bzmj)
)
)
;;;面积标注
(defun bzmj (/ TXTSIZEHEADTXT PRECISION OLDCMD
SEL ENT ENTLIST ENTNAME VLAENT AREA
PT REGENT
)
(vl-load-com)
(setq TXTSIZE 2.5)
(setq HEADTXT "")
(setq PRECISION 3)
;(setq SEL t)
;(entdel (entlast))
;(while SEL
(setq ENT (entsel "\n选取封闭多义线/面域: "))
(if ENT
(progn
(setq ENTLIST (entget (car ENT)))
(setq ENTNAME (strcase (cdr (assoc 0 ENTLIST))))
(cond
((and (wcmatch ENTNAME "*POLYLINE") ;对象多义线
(setq VLAENT (vlax-ename->vla-object (car ENT)))
(= :vlax-true (vla-get-closed VLAENT))
)
(setq AREA
(strcat HEADTXT
(rtos (vlax-curve-getarea VLAENT) 2 PRECISION)
)
)
(command "_.copy" (car ENT) "" "0,0" "0,0")
(command "region" (car ENT) "")
(setq REGENT (entlast))
(setq
PT (vlax-get (vlax-ename->vla-object REGENT) "centroid")
)
(entdel REGENT)
(command "layer" "set" "ZJ" "")
(command "text" "j" "c" PT TXTSIZE "" AREA)
)
((= ENTNAME "REGION") ;对象为面域
(command "area" "o" (car ENT))
(setq
AREA (strcat HEADTXT (rtos (getvar "area") 2 PRECISION))
)
(setq REGENT (car ENT))
(setq
PT (vlax-get (vlax-ename->vla-object REGENT) "centroid")
)
(entdel (entlast))
(command "layer" "set" "ZJ" "")
(command "text" "j" "c" PT TXTSIZE "" AREA)
(ALERT "\n对象为面域")
)
(t (alert "\n你所选择的对象非封闭多义线!!"))
)
)
;(setq SEL NIL)
)
;)
(princ)
)
;;;选择标注的单位
(defun xzdw (/ dw bzdw)
(initget " 1 2 3 ")
(setq
dw (getkword
"\n请选择标注的单位:(1)平方米/(2)亩/(3)公顷/<1>:"
)
)
(cond
((= dw "1") (setq bzdw "平方米"))
((= dw "2") (setq bzdw "亩"))
((= dw "3") (setq bzdw "公顷"))
(t (setq bzdw "平方米"))
)
)
;;;查询面积的程序,不标注
(defun ubzmj (/ pt os mj m zc table ent entnm1 entnm2)
(setq table (entget (entlast)))
(setq entnm1 (assoc -1 table))
(setq entnm1 (cdr entnm1))
(setq pt (getpoint "请在区域内任意一点"))
(command "bpoly" pt "")
(setq ent (entlast))
(setq table (entget ent))
(setq entnm2 (assoc -1 table))
(setq entnm2 (cdr entnm2))
(if (equal entnm1 entnm2) ;非T，区域没有闭合
(alert "区域没有封闭，无法进行面积计算，请检查！") ;end yes
(progn
(command "area" "o" ent)
(entdel ent)
(setq mj (getvar "area"))
(setq m (/ mj 666.667))
(setq zc (getvar "perimeter"))
(setq MJ (rtos MJ))
(setq m (rtos m))
(setq ZC (rtos ZC))
(setq str (strcat "地块面积="MJ "(平方米) = "
m "(亩)" "\n区域周长="
ZC
)
)
(alert str)
(princ "\n地块面积(平方米) = ")
(princ mj)
(princ "\t折合为(亩) = ")
(princ m)
(princ "\t区域周长=")
(princ zc)
) ;END PROGN
) ;END IF
(princ)
) 非常感谢tjztsh的解答，希望日后继续指教。不知有无ARX 编写的，那就在好不过了。 谢谢了 下载了
页:
[1]