动态调整面积--(半成品源码:稍有遗憾）

尘缘一生 · 发表于 2023-1-7 21:04:34

本帖最后由尘缘一生于 2023-1-10 00:38 编辑

各位：在本坛看到两个动画，为实现这两个功能，我写下代码，

然而，对动态调边这个问题，却总有某个边不能成功，还在思考中。。。
发上来，高手看看，还有没有更好的思路与实现他途，我相信，这个调边代码指定在谁手里，而实现的办法也绝不是我这么想的路子，毕竟这是我目前能想出来的办法了，鉴于这个函数的重要性，还是本坛最好完美实现了它为好。

一：动态调边（存在缺憾、但达到了使用级别）

- ;;曲线线所点击子段的两端点列表----(一级)---
  ;;(sl:pick2pt (car (setq e (entsel))) (cadr e))
  (defun sl:pick2pt (nam p / pp n ll lis tp obj)
    (setq tp (dxf1 nam 0) obj (en2obj nam) ll (length (get-pl-pt nam)))
    (if (or
        (and (= "LWPOLYLINE" tp) (= (dxf1 nam 90) 2))
        (and (= "POLYLINE" tp) (= ll 2))
        (= "LINE" tp)
     )
  (setq lis (list (vlax-curve-getstartpoint obj) (vlax-curve-getendpoint obj)))
  (progn
     (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
        n (fix (vlax-curve-getparamatpoint obj pp))
     )
     (setq lis
        (list
        (vlax-curve-getPointAtParam obj n)
        (if (> (1+ n) (1- ll))
           (vlax-curve-getPointAtParam obj 0)
           (vlax-curve-getPointAtParam obj (1+ n))
        )
        )
     )
  )
    )
    lis
  )
;;多边型边-->动态调整面积并显示
;; by 尘缘一生 qq 15290049
;;支持 LWPOLYLINE,POLYLINE
(defun c:kk (/ loop oldos p0 e nam nam1 h obj ang ps pe str n1 n3 k p p1 p2 p3 p4 p1-1 p3-1 plis pts ent lw ly cl lt)
(setq loop t oldos (getvar "osmode"))
(setvar "osmode" 514)
(setq p0 (getpoint "pick point:"))
(setq e (ssget "C" (polar p0 pi4 0.001) (polar p0 5pi4 0.001) '((0 . "LWPOLYLINE,POLYLINE"))))
(setq nam (ssname e 0))
(if (= (dxf1 nam 0) "POLYLINE")
(progn
(setq ent (entget nam) lw (linwind nam) ly (dxf1 ent 8) cl (ss-getcolor ent) lt (ss-linetype ent) pts (get-pl-pt nam))
(entdel nam)
(if (= (dxf1 ent 70) 9) ;闭合
(slch:lwpolyline pts t lw ly cl 1.0) ;闭合
(slch:lwpolyline pts nil lw ly cl 1.0) ;不闭合
)
(setq nam (entlast))
(vla-put-linetype (en2obj nam) lt)
)
)
(if nam
(progn
(setq
obj (en2obj nam)
pts (sl:pick2pt nam p0)
p1 (car pts)
p3 (cadr pts)
ang (angle p1 p3)
str (rtos (vlax-curve-getarea obj) 2 3)
ps (vlax-curve-getstartpoint nam)
pe (vlax-curve-getendpoint nam)
)
(entmake (list '(0 . "CIRCLE") (cons 10 p1) (cons 40 0.01)))
(setq nam1 (entlast))
(setq pts (sl-Curveinters nam nam1 0))
(entdel nam1)
(repeat (setq k (length pts))
(setq p0 (nth (setq k (1- k)) pts))
(if (> (- (+ (distance p0 p1) (distance p0 p3)) (distance p1 p3)) 0)
(setq p2 p0)
)
)
(if (null p2)
(if (> (- (+ (distance ps p1) (distance ps p3)) (distance p1 p3)) 0)
(setq p2 ps)
(setq p2 pe)
)
)
(entmake (list '(0 . "CIRCLE") (cons 10 p3) (cons 40 0.01)))
(setq nam1 (entlast))
(setq pts (sl-Curveinters nam nam1 0))
(entdel nam1)
(repeat (setq k (length pts))
(setq p0 (nth (setq k (1- k)) pts))
(if (> (- (+ (distance p0 p1) (distance p0 p3)) (distance p1 p3)) 0)
(setq p4 p0)
)
)
(if (null p4)
(if (> (- (+ (distance ps p1) (distance ps p3)) (distance p1 p3)) 0)
(setq p4 ps)
(setq p4 pe)
)
)
(if nam$ (entdel nam$))
(slmkwz str (e-mid nam) nil nil nil "PUB_TEXT" nil nil "m")
(setq nam$ (entlast))
(setq ent (entget nam$))
(setq pts (vlax-variant-value (vla-get-coordinates obj)))
(setq n1 (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans p1 1 0)))))
(setq n3 (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans p3 1 0)))))
(while loop
(setq p (grread t) k (car p) p (cadr p))
(if (= k 3) (setq loop nil))
(if (= (setq p1-1 (inters p1 p2 p (polar p ang 2.0) nil)) nil) ;bug出在这里
(setq p1-1 p1)
)
(if (= (setq p3-1 (inters p3 p4 p (polar p ang 2.0) nil)) nil) ;bug出在这里
(setq p3-1 p3)
)
(setq d1 (distance p1-1 p1) d2 (distance p3-1 p3))
(if (> d1 0)
(progn
(vlax-safearray-put-element pts (* n1 2) (car p1-1))
(vlax-safearray-put-element pts (1+ (* n1 2)) (cadr p1-1))
)
)
(if (> d2 0)
(progn
(vlax-safearray-put-element pts (* n3 2) (car p3-1))
(vlax-safearray-put-element pts (1+ (* n3 2)) (cadr p3-1))
)
)
(if (or (> d1 0) (> d2 0))
(progn
(vla-put-coordinates obj pts)
(setq
plis (e-box4 nam t)
p0 (sl:mid (car plis) (caddr plis))
h (* 0.2 (distance (car plis) (cadddr plis)))
)
(entmod (emod (emod (emod (emod ent 1 (rtos (vlax-curve-getarea obj) 2 3)) 40 h) 10 p0) 11 p0))
)
)
)
)
)
(setvar "osmode" oldos)
)

二：动态顶点调整（已完美）

;;多边型顶点-->动态调整面积并显示
;; by 尘缘一生 qq 15290049
;;支持 LWPOLYLINE,POLYLINE
(defun c:kk1 (/ loop p0 e nam h obj n str k p plis pts ent lw ly cl lt)
(setq loop t oldos (getvar "osmode"))
(setvar "osmode" 37)
(setq p0 (getpoint "pick point:"))
(setq e (ssget "C" (polar p0 pi4 0.001) (polar p0 5pi4 0.001) '((0 . "LWPOLYLINE,POLYLINE"))))
(setq nam (ssname e 0))
(if (= (dxf1 nam 0) "POLYLINE")
(progn
(setq ent (entget nam) lw (linwind nam) ly (dxf1 ent 8) cl (ss-getcolor ent) lt (ss-linetype ent) pts (get-pl-pt nam))
(entdel nam)
(if (= (dxf1 ent 70) 9) ;闭合
(slch:lwpolyline pts t lw ly cl 1.0) ;闭合
(slch:lwpolyline pts nil lw ly cl 1.0) ;不闭合
)
(setq nam (entlast))
(vla-put-linetype (en2obj nam) lt)
)
)
(if nam
(progn
(setq
obj (en2obj nam)
n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans p0 1 0))))
str (rtos (vlax-curve-getarea obj) 2 3)
)
(if nam$ (entdel nam$))
(slmkwz str (e-mid nam) nil nil nil "PUB_TEXT" nil nil "m")
(setq nam$ (entlast))
(setq ent (entget nam$))
(setq pts (vlax-variant-value (vla-get-coordinates obj)))
(while loop
(setq p (grread t))
(setq k (car p) p (cadr p))
(if (= k 3) (setq loop nil))
(setq
plis (e-box4 nam t)
p0 (sl:mid (car plis) (caddr plis))
h (* 0.2 (distance (car plis) (cadddr plis)))
)
(vlax-safearray-put-element pts (* n 2) (car p))
(vlax-safearray-put-element pts (1+ (* n 2)) (cadr p))
(vla-put-coordinates obj pts)
(entmod (emod (emod (emod (emod ent 1 (rtos (vlax-curve-getarea obj) 2 3)) 40 h) 10 p0) 11 p0))
)
)
)
(setvar "osmode" oldos)
)

尘缘一生 · 发表于 2023-1-9 13:41:02

本帖最后由尘缘一生于 2023-1-9 17:42 编辑

差不多了，记录在案，不再修改

;;多义线顶点表LWPOLYLINE,POLYLINE-----(一级)-----
;;modify by 尘缘一生 qq 15290049
(defun get-pl-pt (enam / i v lst)
(setq i -1)
(while (setq v (vlax-curve-getpointatparam enam (setq i (1+ i))))
(setq lst (cons v lst))
)
(3Pl=>3Pl0 (gps->lst-delsame lst))
)
;;曲线线所点击子段的两端点列表(z轴已归零)----(一级)---
;;(sl:pick2pt (car (setq e (entsel))) (cadr e)) modify by 尘缘一生 qq 15290049
(defun sl:pick2pt (nam p / pp n ll lis tp obj)
(setq tp (dxf1 nam 0) obj (en2obj nam) ll (length (get-pl-pt nam)))
(if (or
(and (= "LWPOLYLINE" tp) (= (dxf1 nam 90) 2))
(and (= "POLYLINE" tp) (= ll 2))
(= "LINE" tp)
)
(setq lis (3Pl=>3Pl0 (list (vlax-curve-getstartpoint obj) (vlax-curve-getendpoint obj))))
(progn
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(setq lis
(3Pl=>3Pl0
(list
(vlax-curve-getPointAtParam obj n)
(if (> (1+ n) (1- ll))
(vlax-curve-getPointAtParam obj 0)
(vlax-curve-getPointAtParam obj (1+ n))
)
)
)
)
)
)
lis
)
;;曲线线所点击子段点前2点后两点列表----(一级)--- by 尘缘一生 qq 15290049
;;当曲线2点时，前面重合2点，后面重合2点
;;支持 LWPOLYLINE,POLYLINE
;;(sl:pick4pt (car (setq e (entsel))) (cadr e))
;;(p1 p2 p3 p4) z轴已归零 (get-pl-pt (car (setq e (entsel))))
(defun sl:pick4pt (nam p / pp n pts plis)
(setq pts (get-pl-pt nam) plis (sl:pick2pt nam p) p2 (car plis) p3 (cadr plis))
(if (>= (setq n (position p2 pts)) 1)
(setq pp (nth (1- n) pts))
(setq pp (last pts))
)
(if (> (- (+ (distance pp p2) (distance pp p3)) (distance p2 p3)) 0)
(setq p1 pp)
(if (null p1)
(if (= (setq pp (nth (1+ n) pts)) nil)
(setq p1 (car pts))
(if (> (- (+ (distance pp p2) (distance pp p3)) (distance p2 p3)) 0)
(setq p1 pp)
)
)
)
)
(if (>= (setq n (position p3 pts)) 1)
(setq pp (nth (1- n) pts))
(setq pp (last pts))
)
(if (> (- (+ (distance pp p2) (distance pp p3)) (distance p2 p3)) 0)
(setq p4 pp)
(if (null p4)
(if (= (setq pp (nth (1+ n) pts)) nil)
(setq p4 (car pts))
(if (> (- (+ (distance pp p2) (distance pp p3)) (distance p2 p3)) 0)
(setq p4 pp)
)
)
)
)
(list p1 p2 p3 p4)
)
;;返回a在表lst中的位置 or nil----(一级)-----
;;(position x '(a b c)) -> nil, (position 'b '(a b c d)) -> 1
(defun position (x lst / ret)
(if (not (zerop (setq ret (length (member x lst)))))
;x不在表中返回nil
(- (length lst) ret)
)
)
;替换表中所有旧项(支持任意嵌套表)---(一级)---
(defun substitem (newitem olditem lst / x tmplst)
(foreach x (subst newitem olditem lst)
(if (listp x)
(setq tmplst (append tmplst (list (substitem newitem olditem x))))
(setq tmplst (append tmplst (list x)))
)
)
tmplst
)
;;多边型边-->动态调整面积并显示 by 尘缘一生 qq 15290049
;;支持 LWPOLYLINE,POLYLINE
(defun c:dt-line-mj (/ loop oldos p0 nam obj ang str k kk p p1 p2 p3 p4 p1-1 p3-1 plis pts ent lw ly cl lt)
(setq loop t oldos (getvar "osmode"))
(setvar "osmode" 514)
(setq p0 (getpoint "pick point:"))
(setq nam (ssname (ssget "C" (polar p0 pi4 0.001) (polar p0 5pi4 0.001) '((0 . "LWPOLYLINE,POLYLINE"))) 0))
(if (= (dxf1 nam 0) "POLYLINE")
(progn
(setq ent (entget nam) lw (linwind nam) ly (dxf1 ent 8) cl (ss-getcolor ent) lt (ss-linetype ent) pts (get-pl-pt nam))
(entdel nam)
(if (= (dxf1 ent 70) 9) ;闭合 8不闭合
(slch:lwpolyline pts t lw ly cl 1.0)
(slch:lwpolyline pts nil lw ly cl 1.0)
)
(setq nam (entlast))
(vla-put-linetype (en2obj nam) lt)
)
)
(if (setq
plis (sl:pick4pt nam p0)
p1 (car plis)
p2 (cadr plis)
p3 (caddr plis)
p4 (cadddr plis)
ang (angle p2 p3)
obj (en2obj nam)
ent0 (entget nam)
str (strcat (rtos (* (getvar "dimlfac") (getvar "dimlfac") (vlax-curve-getarea obj) 0.000001) 2 2) (slmsg "平方米" "キよμ" "Square meter"))
pts (get-pl-pt nam)
)
(progn
(if nam$ (entdel nam$))
(slmkwz str (e-mid nam) nil nil nil "PUB_TEXT" nil nil "m")
(setq nam$ (entlast))
(setq ent (entget nam$))
(while loop
(setq p (grread t) k (car p) p (cadr p))
(if (= k 3) (setq loop nil))
(if (= (setq p1-1 (inters p1 p2 p (polar p ang 2.0) nil)) nil)
(setq p1-1 p2)
)
(if (= (setq p3-1 (inters p3 p4 p (polar p ang 2.0) nil)) nil)
(setq p3-1 p3)
)
(if (> (distance p1-1 p2) 0)
(setq pts (substitem p1-1 p2 pts) p2 p1-1 kk t)
)
(if (> (distance p3-1 p3) 0)
(setq pts (substitem p3-1 p3 pts) p3 p3-1 kk t)
)
(if (= kk t)
(progn
(entmod (reent ent0 pts))
(setq
plis (e-box4 nam t)
p0 (sl:mid (car plis) (caddr plis))
str (strcat (rtos (* (getvar "dimlfac") (getvar "dimlfac") (vlax-curve-getarea obj) 0.000001) 2 2) (slmsg "平方米" "キよμ" "Square meter"))
)
(entmod (emod (emod (emod (emod ent 1 str) 40 (* 0.1 (distance (car plis) (cadddr plis)))) 10 p0) 11 p0))
)
)
)
)
)
(setvar "osmode" oldos)
)

liuhe · 发表于 2023-1-7 21:28:54

leemac 倒是有一个类似的代码，效果看着差不多。看介绍是用的字段，可以同步更新
http://www.lee-mac.com/areastofield.html

liuhe · 发表于 2023-1-8 08:48:37

aws 发表于 2023-1-7 21:55
大佬，能不能用标注来控制？最终达到SW那种约束的效果？

点太多了吧，要控制那个点更改面积呢

aws · 发表于 2023-1-7 21:55:41

大佬，能不能用标注来控制？最终达到SW那种约束的效果？

Bao_lai · 发表于 2023-1-8 06:12:23

值得敬佩，熬夜不好。

中国梦 · 发表于 2023-1-8 07:08:39

值得敬佩，熬夜不好。

aws · 发表于 2023-1-8 20:13:15

liuhe 发表于 2023-1-8 08:48
点太多了吧，要控制那个点更改面积呢

那种东西，不是考虑面积了。主要是来控制边线。

杜阳 · 发表于 2023-1-8 21:16:16

chixun99 · 发表于 2023-1-13 14:01:11

必须收藏学习。

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

动态调整面积--(半成品源码:稍有遗憾）

本帖子中包含更多资源

点评

点评

点评