动态调整面积--(半成品源码:稍有遗憾）
本帖最后由 尘缘一生 于 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 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)
[*])
leemac倒是有一个类似的代码，效果看着差不多。看介绍是用的字段，可以同步更新
http://www.lee-mac.com/areastofield.html aws 发表于 2023-1-7 21:55
大佬，能不能用标注来控制？最终达到SW那种约束的效果？
点太多了吧，要控制那个点更改面积呢 大佬，能不能用标注来控制？最终达到SW那种约束的效果？ 值得敬佩，熬夜不好。
值得敬佩，熬夜不好。 liuhe 发表于 2023-1-8 08:48
点太多了吧，要控制那个点更改面积呢
那种东西，不是考虑面积了。主要是来控制边线。 必须收藏学习。
页:
[1]
2