如何在拖动多段线一拐点的过程中面积实时改变

changyiran · 发表于 2014-11-25 15:37

newbuser 发表于 2014-11-24 11:31
小试了下牛刀，初步测试应该可以满足您的要求。

谢谢你，你这是用反应器实现的，我用grread也已经实现了

Gu_xl · 发表于 2014-11-25 19:42

changyiran 发表于 2014-11-25 15:37
谢谢你，你这是用反应器实现的，我用grread也已经实现了

既然用grread已经实现了，那就发上来和大家分享下，论坛的宗旨就是互相分享！大家才能共同进步！

香田里浪人 · 发表于 2014-11-25 20:36

能否实现面积表示s＝

changyiran · 发表于 2014-11-25 21:10

Gu_xl 发表于 2014-11-25 19:42
既然用grread已经实现了，那就发上来和大家分享下，论坛的宗旨就是互相分享！大家才能共同进步！

听G版的，现在发上来

changyiran · 发表于 2014-11-25 21:11

(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))
)
)
)
)
)
)

(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)) 
                  ) 
             ) 
      ) 
     ) 
   ) 
 )

changyiran · 发表于 2014-11-25 21:13

changyiran 发表于 2014-11-25 21:11

本程序受学院派院长启发，特此感谢！

Gu_xl · 发表于 2014-11-26 00:24

changyiran 发表于 2014-11-25 21:11

缺少函数fjdb、wzgx！
另外程序没有考虑ucs和wcs的问题！当ucs和wcs不一致时程序肯定出错！

changyiran · 发表于 2014-11-26 09:28

Gu_xl 发表于 2014-11-26 00:24
缺少函数fjdb、wzgx！
另外程序没有考虑ucs和wcs的问题！当ucs和wcs不一致时程序肯定出错！

版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成的，另外fjdb和wzgx是我编的函数，一个是求拐点坐标，一个是判断点在多边形内外，感觉比较简单就没放上去。

soly2006 · 发表于 2014-11-26 15:51

changyiran 发表于 2014-11-26 09:28
版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成 ...

希望补齐完整息定函数，函数参数用法不好判断，谢谢

ps122hb · 发表于 2014-11-28 08:21

changyiran 发表于 2014-11-26 09:28
版主高见，怪不得为啥我有时候第一次运行程序时会出错，第二次就恢复正常了，估计就是ucs和wcs不一致造成 ...

期待完整版出现，多谢

账号		自动登录	找回密码
密码			注册

[讨论] 如何在拖动多段线一拐点的过程中面积实时改变