cable2004 发表于 2015-8-18 20:04 static/image/common/back.gif
还要考虑一个bug，就是当梯形两边延伸到一点后面积还达不到要求，然后转三角形延伸！
单边调整的是有考虑您说的这个问题，在达不到面积要求的时候出现警告表示「达不到面积要求」然后跳出。
因为原本的想法是既然已经达不到要求转成三角形延伸还是无法符合要求，直接跳出比较快！
来赞一个大师，我写的太啰嗦了但是我技术有限 菜鸟级别 望见谅
(defun PoInPl(pt p / d d0 d1 p1 n);;:点表是否包围指定点
(setq p1(cons(last pt)pt)n 0 d 1e99)
(repeat(length pt)(setq d0(car(PTOLINE p(nth n p1)(nth(setq n(1+ n))p1)))d(if(< d0 d)d0 d)))
(if(equal d 0 1e-8)0
(progn
(setq n 0 d1 1e99 pt(OFFSETPT pt 1 0)p1(cons(last pt)pt))
(repeat(length pt)(setq d0(car(PTOLINE p(nth n p1)(nth(setq n(1+ n))p1)))d1(if(< d0 d1)d0 d1)))
(if(> d1 d)1 -1))))
(defun PlDir(p / n m p1 p2 p3 o a a1 a2)
(setq n(length p)pi2(* pi 2)m 2 p1(nth 0 p)p2(nth 1 p))
(while(< m n)
(setq p3(nth m p)
o(list(/(+(+(car p1)(car p2))(car p3))3)(/(+(+(cadr p1)(cadr p2))(cadr p3))3))
m(if(<(PoInPl p o)1)n(1+ m))))
(setq a(angle o p1) a1(-(angle o p2)a)
a1(if(< a1 0)(+ a1 pi2)a1)
a2(-(angle o p3)a)
a2(if(< a2 0)(+ a2 pi2)a2)
m(if(> a1 a2)t)))
(defun offsetpt(pt d flag / offsetpt1);|falg 0闭合点表，1不闭合它;d<0向内>0向外(假定它有内外)|;
(defun offsetpt1(pt d flag / m0 m n pi2 d1 p1 p0 p q0 q2 q22 q1 q pt1 pt2 fx)
(setq m(length pt)d1(abs d)n flag
pi15(*(if(> d 0)1 -1) pi 1.5)pt2 pt)
(while(< n(- m flag))
(setq p(nth n pt2)
p0(if(<(1- n)0)(last pt2)(nth(1- n)pt2))
p1(if(=(1+ n)m)(car pt2)(nth(1+ n)pt2))
n(1+ n)
ang1(+(angle p0 p)pi15)
ang2(+(angle p p1)pi15)
q(inters (polar p0 ang1 d1)(polar p ang1 d1)(polar p ang2 d1)(polar p1 ang2 d1) nil)
q(if q q (polar p ang2 d1)))
(if(=(* flag n)2)(setq pt1(append pt1(list q0))))
(setq pt1(append pt1(list q)))
(if(=(* flag n)(- m flag))(setq pt1(append pt1(list q1)))))
pt1)
(if(= flag 0)
(setq d0(apply '+(mapcar'(lambda(x)(distance(nth(1-(vl-position x pt))pt)x))(cdr pt)))
pt1(offsetpt1 pt(if(> d 0)0.1 -0.1)flag)
d1(apply '+(mapcar'(lambda(x)(distance(nth(1-(vl-position x pt1))pt1)x))(cdr pt1)))
pt1(offsetpt1(if((if(> d 0)> <)d1 d0)pt(reverse pt))d flag)
pt1(if((if(> d 0)> <)d1 d0)pt1(reverse pt1)))
(offsetpt1 pt d flag)))
(defun Plinexy(e / p a b n ob q et d d1 en et) ;;多线段节点坐标(滤掉了多余点，未处理假闭合)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q))))
)))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))
))
P)
(defun ptoline(p p1 p2 / l a b c d);;p在线外p1近端点p2远端点
(setq a(distance p1 p2)
c(distance p p1)
b(distance p p2)
l(/(-(+(* a a)(* c c))(* b b))(* a 2))
d(polar p1(angle p1 p2)(abs l)))
(if(< 0 l a)(list(distance p d)p d)
(if(> b c)(list c p p1)(list b p p2))))
;;164.32 [功能] 多段线反向(起点反成终点) byzml84
;;(HH:LWPOLYLINEFX (car (entsel)))
(defun HH:LWPOLYLINEFX (EN / A B C D ENT LST LST1 TMP)
(setq ENT (entget EN))
(setq tmp ent)
(while (setq tmp (member (assoc 10 tmp) tmp))
(setq a (assoc 10 tmp)
b (cons 40 (cdr (assoc 41 tmp)))
c (cons 41 (cdr (assoc 40 tmp)))
d (cons 42 (- (cdr (assoc 42 tmp))))
LST (append (list b c d a) LST)
)
(setq tmp (cddddr tmp))
)
(repeat 3 (setq LST (append (cdr lst) (list (car lst)))))
(setq lst1 (reverse (cdr (member (assoc 10 ent) (reverse ent)))))
(entmod (append lst1 lst '((210 0 0 1))))
)
;;;;;;;
(defun getplarea (l)
(* 0.5
(apply
'+
(mapcar
'(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))
l
(append (cdr l) (list (car l)))
)
)
)
)
;;;;;;;
;; 獲取聚合線點表
(defun vxs (e / i v lst)
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
;;;;;;;;;;;
(defun c:tt ( / ent ent1 mj demj pzx xzp pzx1 xzp1a b d s l k lwpy pt mt jiaodian dianbiao jiaodian-a jiaodian1)
(setq ent1 (car (entsel "\n请选择需要改变的多段线")))
(setq demj (vlax-curve-getArea(vlax-ename->vla-object ent1)))
(prompt (strcat "\n原多段线面积为："(rtos demj 2 3)))
(setq mj (getreal "\n请输入调整后面积："))
;;164.18 [功能] 多段线所点击子段的两相邻线端点列表
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr en))
(defun HH:PickSegEndPt (obj p / pp n)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n(fix (vlax-curve-getparamatpoint obj pp))
nn (- (length (vxs obj)) 1)
)
(list (vlax-curve-getPointAtParam obj (if (> (1- n) 0) (1- n) (+ n -1 nn)))
(vlax-curve-getPointAtParam obj n)
(vlax-curve-getPointAtParam obj (if (< (1+ n) nn) (1+ n) (- (+ n 1 ) nn)))
(vlax-curve-getPointAtParam obj (if (< (+ n 2) nn) (+ n 2) (- (+ n 2) nn)))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (= (pldir(plinexy ent1)) T)
(HH:LWPOLYLINEFX ent1)
)
(setq dianbiao (HH:PickSegEndPt (car(setq en(entsel "请选择需要改变的多段线的一边"))) (cadr en)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (> mj demj)
(progn
(setq pzx (angle (nth 0 dianbiao)(nth 1 dianbiao)))
(setq xzp (angle (nth 2 dianbiao)(nth 1 dianbiao)))
(setq pzx1 (angle (nth 2 dianbiao)(nth 1 dianbiao)))
(setq xzp1 (angle (nth 2 dianbiao)(nth 3 dianbiao)))
(setq jiaodian (inters (nth 0 dianbiao)(nth 1 dianbiao) (nth 3 dianbiao)(nth 2 dianbiao) nil ))
(if (< (abs (getplarea (list (nth 2 dianbiao)(nth 1 dianbiao) jiaodian))) (- mj demj)) (print (strcat "此线段无法调整至指定面积,必须小于"
(rtos (+ (abs (getplarea (list (nth 2 dianbiao)(nth 1 dianbiao) jiaodian))) demj) 2 3) )
)
)
(setq b (- xzp pzx pi) )
(setq a(- xzp1 pzx1 pi) )
(setq d (distance (nth 2 dianbiao)(nth 1 dianbiao)))
(setq s (- mj demj))
;(setq l( / (+ (* 2 d (sin b)) (sqrt (- (expt (* -2 d (sin b)) 2) (* 8 s (/ (sin b) (sin a)) (sin (- pi a b) ) ) ))
; )
;(* 2 (/ (sin b) (sin a))(sin (- pi a b) )))
; )
(if (> (abs (getplarea (list (nth 2 dianbiao)(nth 1 dianbiao) jiaodian))) (- mj demj))
(setq l( / (- (* 2 d (sin b)) (sqrt (- (expt (* -2 d (sin b)) 2) (* 8 s (/ (sin b) (sin a)) (sin (- pi a b) ) ) ))
)
(* 2 (/ (sin b) (sin a))(sin (- pi a b) )))
)
)
(setq k (* (sin b) (/ l (sin a))
))
(print l)
(print k)
(princ)
(setq pt (polar (nth 1 dianbiao) pzx l) )
(setq mt (polar (nth 2 dianbiao) (angle (nth 3 dianbiao)(nth 2 dianbiao)) k) )
(entmake (list '(0 . "point")(cons 10 pt) ))
(entmake (list '(0 . "point")(cons 10mt) ))
(entmake (list '(0 . "point")(cons 10jiaodian) ))
(entmod(subst(cons 10 mt)(cons 10(mapcar'+'(0 0)(nth 2 dianbiao)))
(subst(cons 10 pt)(cons 10(mapcar'+'(0 0)(nth 1 dianbiao)))
(entget (car en)))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if(<mj demj)
(progn
(setq pzx (angle (nth 0 dianbiao)(nth 1 dianbiao)))
(setq xzp (angle (nth 2 dianbiao)(nth 1 dianbiao)))
(setq pzx1 (angle (nth 2 dianbiao)(nth 1 dianbiao)))
(setq xzp1 (angle (nth 2 dianbiao)(nth 3 dianbiao)))
(setq b (- xzp pzx pi) )
(setq a(- xzp1 pzx1 pi) )
(setq d (distance (nth 2 dianbiao)(nth 1 dianbiao)))
(setq s (- demj mj))
;;;子程序 (p-l1), 求点到直线距离程序的前半部分 (求常数'c1','c2'和'c3')。
;;;参数 'p1' 和 'p2' 为直线的两个端点。
(defun pl1 (p1 p2 p0 / x1 y1 x2 y2 c1 c2 c3)
(setq x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
c1 (- y2 y1)
c2 (- x1 x2)
c3 (sqrt (+ (* c1 c1) (* c2 c2)))
c1 (/ c1 c3)
c2 (/ c2 c3)
c3 (/ (- (* x2 y1) (* x1 y2)) c3)
juli (+ (* c1 (car p0)) (* c2 (cadr p0)) c3)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (<(pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 0 dianbiao)) (pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 3 dianbiao)))
(progn
(setq jiaodian-a (polar (nth 2 dianbiao)(- xzp (* 0.5 pi)) (pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 0 dianbiao)) ))
(setq jiaodian1 (inters (nth 0 dianbiao) jiaodian-a(nth 2 dianbiao)(nth 3 dianbiao) nil))
(alert (strcat "减小面积不能大于" (rtos (abs (getplarea (list jiaodian1 (nth 2 dianbiao) (nth 1 dianbiao) (nth 0 dianbiao)) )) 2 3)))
)
(if(>(pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 0 dianbiao)) (pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 3 dianbiao)))
(progn
(setq jiaodian-a (polar (nth 1 dianbiao)(+ (angle (nth 1 dianbiao)(nth 2 dianbiao)) (* 0.5 pi)) (pl1 (nth 2 dianbiao)(nth 1 dianbiao) (nth 3 dianbiao)) ))
(setq jiaodian1 (inters (nth 3 dianbiao) jiaodian-a(nth 0 dianbiao)(nth 1 dianbiao) nil))
(alert (strcat "减小面积不能大于" (rtos (abs (getplarea (list jiaodian1 (nth 1 dianbiao) (nth 2 dianbiao) (nth 3 dianbiao)) )) 2 3)))
)
)
)
;(setq l( / (+ (* 2 d (sin b)) (sqrt (- (expt (* -2 d (sin b)) 2) (* 8 s (/ (sin b) (sin a)) (sin (- pi a b) ) ) ))
; )
;(* 2 (/ (sin b) (sin a))(sin (- pi a b) )))
; )
(setq l(abs ( / (+ (* -2 d (sin b)) (sqrt (+ (expt (* 2 d (sin b)) 2) (* 8 s (/ (sin b) (sin a)) (sin (- pi a b) ) ) ))
)
(* 2 (/ (sin b) (sin a))(sin (- pi a b) ))))
)
(setq k (abs(* (sin b) (/ l (sin a))
))
)
(print l)
(print k)
(princ)
(setq pt (polar (nth 1 dianbiao) (angle (nth 1 dianbiao)(nth 0 dianbiao)) l) )
(setq mt (polar (nth 2 dianbiao) (angle (nth 2 dianbiao)(nth 3 dianbiao)) k) )
(entmake (list '(0 . "point")(cons 10 pt) ))
(entmake (list '(0 . "point")(cons 10mt) ))
(entmod(subst(cons 10 mt)(cons 10(mapcar'+'(0 0)(nth 2 dianbiao)))
(subst(cons 10 pt)(cons 10(mapcar'+'(0 0)(nth 1 dianbiao)))
(entget (car en)))))
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun HHH:PickSegEndPt (arg / obj p pp n)
(setq obj(car arg)p(last arg))
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n(fix (vlax-curve-getparamatpoint obj pp))
nn (- (length (vxs obj)) 1)
)
(list (vlax-curve-getPointAtParam obj (if (> (1- n) 0) (1- n) (+ n -1 nn)))
(vlax-curve-getPointAtParam obj n)
(vlax-curve-getPointAtParam obj (if (< (1+ n) nn) (1+ n) (- (+ n 1 ) nn)))
(vlax-curve-getPointAtParam obj (if (< (+ n 2) nn) (+ n 2) (- (+ n 2) nn)))
)
)
;(HH:PICKSEGENDPT(entsel))
东抄西抄的
树櫴希德 发表于 2015-8-19 10:35 static/image/common/back.gif
来赞一个大师，我写的太啰嗦了但是我技术有限 菜鸟级别 望见谅东抄西抄的
我也是拼东凑西的，能达到目的才是王道，哈哈！
感谢大师的分享
; 错误: 读入的 (八进制) 字符不正确: 0TMJ2
树櫴希德 发表于 2015-8-19 11:18 static/image/common/back.gif
; 错误: 读入的 (八进制) 字符不正确: 0TMJ2
因为我是繁体转简体，可能会有些字符是有错误的，
建议是打开文件，复制内容再到vlisp里去执行。
本帖最后由 llsheng_73 于 2015-8-19 14:54 编辑
其实有个最大的问题：下图中黄色线为待调整的边，根据程序中的算法可调整该边至红色线位置，但实际上到绿色线位置按原来的算法已经无法处理了，不知道程序中有没处理方法或者进行检测防范，如果没有，那很可能会得出一个自相交图形并且面积不对。
假定黄线绿线为底的梯形面积为300平方，黄线现红线为底的梯形面积800平方，现在要求调整黄线边，面积减小400平方，按程序的设计思路这是可以有解的，但结果肯定不对。。。
边至符合面积
llsheng_73 发表于 2015-8-19 14:44 static/image/common/back.gif
其实有个最大的问题：下图中黄色线为待调整的边，根据程序中的算法可调整该边至红色线位置，但实际上到绿色 ...
程序最后有做完成后的面积的检测，如果发生您所说的情况，会出现面积错误的警告，要再重新处理！
我也正在想如何处理红线的这种情况，如果有办法解决的话，就可以将程序修改成批次的自动分割了！
但是目前还没有想到要怎么处理
Atsai 发表于 2015-8-19 14:56 static/image/common/back.gif
程序最后有做完成后的面积的检测，如果发生您所说的情况，会出现面积错误的警告，要再重新处理！
我也 ...
线有重复点也不能成功，要先删除重复点，用73哥的函数
(defun InsOrDel(lst pos mod / qlst a hlst);{在指定位置删除或插入元素mod为要插入的元素为空时删除第pos项}
(setq a -1)
(setq hlst(vl-member-if-not'(lambda(x)(setq a(1+ a))(if(= a pos) nil(setq qlst (cons x qlst))))lst))
(if mod(apply 'append (list (reverse(cons mod qlst)) hlst))
(apply 'append (list (reverse qlst)(cdr hlst)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Plinexy(e / p a b n ob q et d d1 en et) ;;多线段节点坐标(滤掉了多余点，未处理假闭合)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q))))
)))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))
))
P)
;;;;
(defun RYD(e / s m n f a p);;删除冗余点
(setq p(Plinexy e)ob(vlax-ename->vla-object e)e(entget e)F 0)
(if (or(=(cdr(assoc 70 e))129)(=(cdr(assoc 70 e))1))(setq p(append p(list(car p)))))
(if (=(vlax-curve-getdistatpoint ob(vlax-curve-getendpoint ob))0)
(setq p(reverse(cdr(reverse p)))F 1))
(setq a(list(cons 0 "LWPOLYLINE")(cons 8(cdr(assoc 8 e)))(cons 6(if(assoc 6 e)(cdr(assoc 6 e))""))
(cons 62(if(assoc 62 e)(cdr(assoc 62 e))256))(cons 370(if(assoc 370 e)(cdr(assoc 370 e))0))
(cons 48(if(assoc 48 e)(cdr(assoc 48 e))1))(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline")
(cons 90(-(length P)F))(cons 70 (+ 128 F))(cons 43(if(assoc 43 e)(cdr(assoc 43 e))0))
(cons 38(caddr(vlax-curve-getstartpoint ob)))(assoc 39 e))
a(append(vl-remove (cons 6 "")a)(list(cons 10(car p)))))
(foreach e(cdr P)
(setq e(cons 10 e)
a(if(and(not(member e a))(>(distance(cdr(last a))(cdr e))1e-2))(append a (list e))a)))
(entmod(InsOrDel a 0(assoc -1 e)))
(princ))