二分法根据面积画线，可用于断面图计量人员使用
;;[功能]pline,lwpline点坐标表By 无痕;;[用法](LC:WH-vxs (car (entsel))),返回三维点坐标
(defun LC:WH-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)
)
;[功能]生成射线
;[用法](LC:Entmake-XlineX (getpoint))
(defun LC:Entmake-XlineX (pt)
(entmakeX (list '(0 . "XLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbXline")
(cons 10 pt)
(cons 11 '(1 0 0))
)
)
)
;[功能] 过一点射线与曲线的交点
;;示例(HH:XYCurvePt (car(entsel)) (getpoint) "X"),返回过一点X轴上的点
(defun HH:XYCurvePt (e1 pt Flag / E2 LST PTS)
(setq e2 (LC:Entmake-XlineX pt))
(setq pts (HH:TwoEntsInters e1 e2 0))
(entdel e2)
pts
)
;[功能]根据图元名及一点求X坐标以下部分面积
(defun LC:pts-2pt-area (ENT P1 / PTS2 INTS PTS PTS1)
(setq pts2 '())
(setq ints (HH:XYCurvePt ent p1 "X"));交点
(setq pts (LC:WH-vxs ent));多段线顶点表
(setq pts1 (vl-remove-if'(lambda (x) (> (cadr x) (cadr p1))) pts))
(setq pts2 (append pts2 ints pts1))
(LC:getplarea pts2)
)
;[功能]根据图元名及一点求X坐标以上部分面积
(defun LC:pts-2pt-area1 (ENT P1 / PTS2 INTS PTS PTS1)
(setq pts2 '())
(setq ints (HH:XYCurvePt ent p1 "X"));交点
(setq pts (LC:WH-vxs ent));多段线顶点表
(setq pts1 (vl-remove-if'(lambda (x) (< (cadr x) (cadr p1))) pts))
(setq pts2 (append pts2 ints pts1))
(abs (LC:getplarea pts2))
)
;[功能]点表求面积
(defun LC: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 LC:Make-LWPOLYLINE1 (lst / PT)
(entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(62 . 1)
(cons 90 (length lst))
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)
;;;name:BF-list-delsame
;;;desc:删除表中相同元素，保留第一次出现的位置
;;;arg:lst:列表
;;;arg:buzz:容差
;;;return:删除重复元素组成的表
;;;example:(BF-list-delsame '(0 1 2 3 2 4 4) 0.1)---->(0 1 2 3 4)
(defun BF-list-delsame (lst buzz)
(if Lst
(cons (car Lst)
(BF-list-delsame
(vl-remove-if
'(lambda (x) (equal (car lst) x buzz))
(cdr lst)
)
buzz
)
)
)
)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vlax-ename->vla-object e1))
(setq obj2 (vlax-ename->vla-object e2))
(setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
(while pts
(setq ptl (cons (list (car pts) (cadr pts)) ptl))
(setq pts (cdddr pts))
)
ptl
)
(defun c:mjhx1 (/ ENT PTS1 P1 P2 PT TZAREA AREA1 INTS)
(princ "\n 二分法根据面积画线，可用于断面图计量人员使用")
(setq ent (car (entsel "\n 请选择多段线: "))) ;多段线顶点
(setq pts1 (vl-sort (LC:WH-vxs ent) '(lambda (x y) (> (cadr x) (cadr y)))));点表按X值(测量坐标)从大到小排序
(setq p1 (last pts1));X值最小点(CAD Y值)
(setq p2 (car pts1));X值最大点(CAD Y值)
(setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000));设定起始点
(setq tzarea (getreal "\n 请输入多边形面积: "))
(setq area1 0)
(while (not (equal tzarea area1 0.0001))
(setq ints (HH:XYCurvePt ent pt "X")) ;交点
(setq area1 (abs(LC:pts-2pt-area ent pt)))
(cond
((< area1 tzarea) ;如果计算面积小于指定面积，
(setq p1 pt)
)
((> area1 tzarea) ;如果计算面积大于指定面积，
(setq p2 pt)
)
)
(setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000))
)
(LC:Make-LWPOLYLINE1 ints)
(princ)
)
你的专业知识不太了解，如果你描述清楚的话可以试试 这个真不错，可以扩展开发了。 ;;[功能]pline,lwpline点坐标表By 无痕
;;[用法](LC:WH-vxs (car (entsel))),返回三维点坐标
(defun LC:WH-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)
)
;[功能]生成射线
;[用法](LC:Entmake-XlineX (getpoint))
(defun LC:Entmake-XlineX (pt)
(entmakeX (list '(0 . "XLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbXline")
(cons 10 pt)
(cons 11 '(1 0 0))
)
)
)
;[功能] 过一点射线与曲线的交点
;;示例(HH:XYCurvePt (car(entsel)) (getpoint) "X"),返回过一点X轴上的点
(defun HH:XYCurvePt (e1 pt Flag / E2 LST PTS)
(setq e2 (LC:Entmake-XlineX pt))
(setq pts (HH:TwoEntsInters e1 e2 0))
(entdel e2)
pts
)
;[功能]根据图元名及一点求X坐标以下部分面积
(defun LC:pts-2pt-area-dow (ENT P1 / PTS2 INTS PTS PTS1)
(setq pts2 '())
(setq ints (HH:XYCurvePt ent p1 "X"));交点
(setq pts (LC:WH-vxs ent));多段线顶点表
(setq pts1 (vl-remove-if'(lambda (x) (> (cadr x) (cadr p1))) pts))
(setq pts2 (append pts2 ints pts1))
(LC:getplarea pts2)
)
;[功能]根据图元名及一点求X坐标以上部分面积
(defun LC:pts-2pt-area-up (ENT P1 / )
(setq pts2 '())
(setq ints (HH:XYCurvePt ent p1 "X"));交点
(setq pts (LC:WH-vxs ent));多段线顶点表
(setq pts1 (vl-remove-if'(lambda (x) (< (cadr x) (cadr p1))) pts))
(setq pts2 (append pts2 pts1 ints ))
(LC:getplarea pts2)
)
;[功能]点表求面积
(defun LC: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 LC:Make-LWPOLYLINE1 (lst / PT)
(entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(62 . 1)
(cons 90 (length lst))
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)
;;;name:BF-list-delsame
;;;desc:删除表中相同元素，保留第一次出现的位置
;;;arg:lst:列表
;;;arg:buzz:容差
;;;return:删除重复元素组成的表
;;;example:(BF-list-delsame '(0 1 2 3 2 4 4) 0.1)---->(0 1 2 3 4)
(defun BF-list-delsame (lst buzz)
(if Lst
(cons (car Lst)
(BF-list-delsame
(vl-remove-if
'(lambda (x) (equal (car lst) x buzz))
(cdr lst)
)
buzz
)
)
)
)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vlax-ename->vla-object e1))
(setq obj2 (vlax-ename->vla-object e2))
(setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
(while pts
(setq ptl (cons (list (car pts) (cadr pts)) ptl))
(setq pts (cdddr pts))
)
ptl
)
(defun c:cxdmmj ()
(setq ent (car(entsel "\n 请选择设计多段线")))
(setq pts (LC:WH-vxs ent));多段线顶点
;(setq pts1 (BF-list-delsame(vl-sort pts1 '(lambda (x y) (< (cadr x) (cadr y))))0.001));点表按X值(测量坐标)从小到大排序
(setq p1 (getpoint"\n 请指定一点"))
(LC:Make-LWPOLYLINE (HH:XYCurvePt ent p1 "X"))
(princ " \n 断面面积为：")
(princ (LC:pts-2pt-area ent p1))
(princ "平方米")
(princ)
)
(defun c:mjhx1 (/ ENT PTS1 P1 P2 PT TZAREA AREA1 INTS)
(princ "\n 二分法根据面积向上画线，可用于断面图计量人员使用,命令：mjhx1 ")
(setq ent (car (entsel "\n 请选择多段线: "))) ;多段线顶点
(setq pts1 (vl-sort (LC:WH-vxs ent) '(lambda (x y) (> (cadr x) (cadr y)))));点表按X值(测量坐标)从大到小排序
(setq p1 (last pts1));X值最小点(CAD Y值)
(setq p2 (car pts1));X值最大点(CAD Y值)
(setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000));设定起始点
(setq tzarea (getreal "\n 请输入多边形面积: "))
(setq area1 0)
(while (not (equal tzarea area1 0.0001))
(setq ints (HH:XYCurvePt ent pt "X")) ;交点
(setq area1 (abs(LC:pts-2pt-area-dow ent pt)))
(cond
((< area1 tzarea) ;如果计算面积小于指定面积，
(setq p1 pt)
)
((> area1 tzarea) ;如果计算面积大于指定面积，
(setq p2 pt)
)
)
(setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000))
)
(LC:Make-LWPOLYLINE1 ints)
(princ)
)
(defun c:mjhx2 (/ ENT PTS1 P1 P2 PT TZAREA AREA1 INTS)
(princ "\n 二分法根据面积向下画线，可用于断面图计量人员使用,命令：mjhx2 ")
(setq ent (car (entsel "\n 请选择多段线: "))) ;多段线顶点
(setq pts1 (vl-sort (LC:WH-vxs ent) '(lambda (x y) (> (cadr x) (cadr y)))));点表按X值(测量坐标)从大到小排序
(setq p1 (last pts1));X值最小点(CAD Y值)
(setq p2 (car pts1));X值最大点(CAD Y值)
(setq pt (list (car p2) (/ (+ (cadr p2) (cadr p1)) 2) 0.000));设定起始点
(setq tzarea (getreal "\n 请输入多边形面积: "))
(setq area1 0)
(while (not (equal tzarea area1 0.0001))
(setq ints (HH:XYCurvePt ent pt "X")) ;交点
(setq area1 (abs(LC:pts-2pt-area-up ent pt)))
(cond
((< area1 tzarea) ;如果计算面积小于指定面积，
(setq p2 pt)
)
((> area1 tzarea) ;如果计算面积大于指定面积，
(setq p1 pt)
)
)
(setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000))
)
(LC:Make-LWPOLYLINE1 ints)
(princ)
) 谢谢! 13648893846分享程序!!!!! 不错，值得学习，顶.. 还可以引申到多边形面积按比例分割，按指定面积分割 本帖最后由 yxh1202 于 2018-10-29 11:53 编辑
前辈你好，看到你这个帖子为我提供了一个想法，我们是做水工的，经常要根据流量水位关系计算河道的水面线，公式如下：
Q=AC（R*I）^(0.5)
C=1/N*R^(1/6)
其中：A===过水面积
N===河道糙率，常数
R===水力半径，R=A/W
W===湿周，就是过水断面的周长减去水面线长度。
根据你的这个mjhx1代码，感觉能实现试算出来已知Q情况下的水深。请提供指导 过水面积应该就是我这里指定的面积，公式你自己套一下看看 用的时候你注意一下，我所标注的X是指测量坐标，跟CAD是相反的
页:
[1]
2