 - ;changyiran版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成的，另外fjdb和wzgx是我编的函数，一个是求拐点坐标，一个是判断点在多边形内外，感觉比较简单就没放上去
- (defun wzgx(pt e / p e1 area area1 dist dist1)
- (setq e(vlax-ename->vla-object e)dist(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e pt))area(vla-get-area e)
- e1(car(vlax-safearray->list(vlax-variant-value(vla-offset e(* dist 1e-4)))))area1(vla-get-area e1)
- dist1(distance(reverse(cdr(reverse pt)))(vlax-curve-getclosestpointto e1 pt))) (entdel(entlast))
- (if(< dist 1e-6)0;;线上
- (if(>(*(- area1 area)(- dist1 dist))0)1 -1)));1线内-1线外
- ;[功能] pline,lwpline点坐标表 By 无痕;;示例(vxs (car (entsel))),返回三维点坐标
- (defun fjdb (e / i v lst)
- (setq i 0)
- (while
- (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
- (setq lst (cons v lst))
- )
- (reverse lst))
- ;;;;;;;;;;;;;;;
- (defun c:dtmj(/ );动态面积
- (command"undo""m")
- (if(and(setq en(car(setq xz(entsel"\n请选择地块线："))))
- (="地块线"(cdr(assoc 8(setq el(entget en)))))
- )
- (progn
- (setq bb(fjdb en)
- obj(vlax-ename->vla-object en)
- mjss(ssget'"cp"bb'((0 . "text")(8 . "实测面积")))
- n -1
- )
- (repeat(sslength mjss)
- (setq men(ssname mjss(setq n(1+ n))))
- (setq zdzd(cdr(assoc 11(entget men))))
- (if(=(wzgx zdzd en)1)
- (setq mjen men)
- )
- )
- (setq
- pt(cadr xz)
- zjd(vlax-curve-getclosestpointto obj pt)
- cs(vlax-curve-getParamAtPoint obj zjd)
- cs(atoi(rtos cs 2 0))
- pt(vlax-curve-getpointatparam obj cs)
- pt(list(car pt)(cadr pt))
- mode t
- )
- (while mode
- (setq mo(grread t 15 0)
- co(car mo)
- )
- (cond((member co '(2 3 25 32)) ;其它 右键 右键 空格
- (setq mode nil)
- )
- (t
- (setq p1(cadr mo))
- (entmod(subst(cons 10 p1)(cons 10 pt)el))
- (setq bb(fjdb en))
- (setq zxzb(list(/(apply'+(mapcar'(lambda(x)(car x))bb))(length bb))(/(apply'+(mapcar'(lambda(x)(cadr x))bb))(length bb))))
- (setq mj(rtos(*(vla-get-area obj)0.0015) 2 2))
- (setq mjel(subst(cons 1 mj)(assoc 1(entget mjen))(entget mjen)))
- (entmod(subst(cons 11 zxzb)(assoc 11 mjel)mjel))
- )
- )
- )
- )
- )
- )
| 
楼主
显身卡
发表于 2015-8-11 16:25