设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 二分法根据面积画线，可用于断面图计量人员使用
12下一页
返回列表 发新帖
查看: 3964|回复: 16

[函数] 二分法根据面积画线，可用于断面图计量人员使用

[复制链接]
13648893846
发表于 2018-10-20 21:44:55 | 显示全部楼层 |阅读模式
;;[功能]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:删除重复元素组成的表
;;;exampleBF-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)
)

评分

参与人数 1明经币 +1 金钱 +45 收起 理由
树櫴希德 + 1 + 45 很给力!

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

13648893846
 楼主| 发表于 2018-10-29 23:37:26 来自手机 | 显示全部楼层
你的专业知识不太了解，如果你描述清楚的话可以试试
回复 支持 1 反对 0

使用道具 举报

干脆面
发表于 2018-10-21 20:24:06 | 显示全部楼层
这个真不错，可以扩展开发了。
回复 支持 0 反对 1

使用道具 举报

13648893846
 楼主| 发表于 2018-10-28 21:21:21 | 显示全部楼层
;;[功能]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:删除重复元素组成的表
;;;exampleBF-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)
)
回复 支持 反对

使用道具 举报

yoyoho
发表于 2018-10-20 22:30:41 | 显示全部楼层
谢谢! 13648893846分享程序!!!!!
回复 支持 反对

使用道具 举报

bluefcc1
发表于 2018-10-20 22:31:34 | 显示全部楼层
不错，值得学习，顶..
回复 支持 反对

使用道具 举报

13648893846
 楼主| 发表于 2018-10-21 00:36:04 来自手机 | 显示全部楼层
还可以引申到多边形面积按比例分割，按指定面积分割
回复 支持 反对

使用道具 举报

yxh1202
发表于 2018-10-29 11:49:34 | 显示全部楼层
本帖最后由 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情况下的水深。请提供指导
回复 支持 反对

使用道具 举报

13648893846
 楼主| 发表于 2018-10-29 23:39:22 来自手机 | 显示全部楼层
过水面积应该就是我这里指定的面积，公式你自己套一下看看
回复 支持 反对

使用道具 举报

13648893846
 楼主| 发表于 2018-10-29 23:42:51 来自手机 | 显示全部楼层
用的时候你注意一下，我所标注的X是指测量坐标，跟CAD是相反的
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2025-5-19 03:20 , Processed in 0.209592 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表