利用GZXL程序：根据图面三角网查询任意点高程

树櫴希德

根据图面三角网查询任意点高程
;;;;;;;;;三维多段线输出到点表
(defun c:t6 (/ fff ssa cm en ii no wjm pzx)
  (gc)
    (setq cm (getvar "cmdecho"))
    (setvar "cmdecho" 0)
    ;(setq wjm (getfiled "请指定要保存的坐标文件" "e:\\" "txt" 1))
       ;(setq fff (open wjm "w"))
       (setq ssa (ssget '((0 . "POLYLINE") (8 . "sjw"))))
                (setq ii   0
                      no  0
                  )
                  (repeat (sslength ssa)
                       (setq en (ssname ssa ii)
                            ptb (vxs en)
                            pzx (append pzx (list ptb))
                             ii  (1+ ii)               )
                   ; (setq pzx (list (car pt) (cadr pt) (caddr pt)))

                  )
  ;(write-line (strcat pzx) fff)
                 ; (close fff)
                  ;(princ (strcat "\n坐标已存入\"" wjm "\"中"))

    (setvar "cmdecho" cm)
    (princ)

;[功能] pline,lwpline点坐标表  By 无痕;;示例(vxs (car (entsel))),返回三维点坐标
(defun vxs (e / i v lst)
  (setq i 0)
  (while
    (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
     (setq lst (cons v lst))
  )
  (reverse lst))
  (setq sjwlst pzx)
;;双线性内插计算内插高程值
(defun zInsert (ptl / L pt0 pt0x pt0y pt1 pt2 pta ptb ptc ptz r xa xb xc ya yb yc za zb zc zl zr)
  (setq pt0  (car ptl)
        pt0X (car pt0)
        pt0Y (cadr pt0)
        pt1  (polar (list pt0X pt0Y) 0 1000)
        pt2  (polar (list pt0X pt0Y) pi 1000)
        ptA  (car (cadr ptl))
        Xa (car ptA)
        Ya (cadr ptA)
        Za (caddr ptA)
        ptB  (cadr (cadr ptl))
        Xb (car ptB)
        Yb (cadr ptB)
        Zb (caddr ptB)
        ptC  (caddr (cadr ptl))
        Xc (car ptC)
        Yc (cadr ptC)
        Zc (caddr ptC)
  )
  ;求交点
  (setq L (inters pt1 pt2 (list Xa Ya) (list Xb Yb)))
  (cond
    ((/= L nil)
      (setq zL (+ Za (/ (* (- Zb Za) (- (car L) Xa)) (- Xb Xa))))
    )
    ((= L nil)
      (progn
         (setq L (inters pt1 pt2 (list Xb Yb) (list Xc Yc)))
         (setq zL (+ Zb (/ (* (- Zc Zb) (- (car L) Xb)) (- Xc Xb))))
      )
    )
  )
  (setq R (inters pt1 pt2 (list Xa Ya) (list Xc Yc)))
  (cond
    ((/= R nil)
      (setq zr (+ Za (/ (* (- Zc Za) (- (car R) Xa)) (- Xc Xa))))
    )
    ((= R nil)
      (progn
        (setq R (inters pt1 pt2 (list Xb Yb) (list Xc Yc)))
        (setq zr (+ Zb (/ (* (- Zc Zb) (- (car R) Xb)) (- Xc Xb))))
      )
    )
  )
  (setq ptZ (+ zL (/ (* (- zr zL) (- pt0X (car L))) (- (car R) (car L)))))
  (list pt0X pt0Y ptZ)
)
  ;;;创建Cass高程点
(defun Entmakegcd (inspt height scale inserD tag txt ist1 txth ist2 xsws / blkdef d1 d2 d3 d4 obj pt pt1 pt2 pt3 pt4 str1 str2)
  (setvar "CMDECHO" 0)
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
  (if height
    (setq height (rtos height 2 3))
    (setq height "")
  )
  (regapp "SOUTH")
  ;;;检查字体 "HZ" 是否存在
  (if (not (tblobjname "style" "HZ"))
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
  )
  ;;;检查是否存在高程点图块定义
  (if (not (tblobjname "block" "GC200"))
    (progn
      (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
      (setq obj
        (vla-AddPolyline
           blkdef
           (vlax-make-variant
              (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 5))
                 '(-0.2 0 0 0.2 0 0)
              )
           )
        )
      )
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
      (vla-put-Closed obj :vlax-true)
      (vla-put-ConstantWidth obj 0.4)
    )
  )
  (cond
    ((= (car tag) "height")
      ;;;插入高程点
      (entmake (list '(0 . "INSERT") '(100 . "AcDbEntity") '(100 . "AcDbBlockReference") '(66 . 1) (cons 2 "GC200") (cons 10 inspt) (cons 41 scale) (cons 42 scale) (cons 43 scale) '(-3 ("SOUTH" (1000 . "202101")))))
      (entmake (list '(0 . "ATTRIB") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 10 (setq pt (polar inspt 0 (* 1.2 scale)))) (cons 40 (* 2.0 scale)) (cons 50 0) (cons 41 0.8) (cons 51 0) (cons 1 height) (cons 7 "HZ") (cons 72 0) (cons 11 pt) '(100 . "AcDbAttribute") (cons 2 "height") (cons 70  0) (cons 74 2)))
    )
    ((= (car tag) "integer")
      ;;;插入水深点
      (progn
        (setq d1 (distance (list (car (car ist1)) (cadr (car ist1))) (list (car inserD) (cadr inserD))))
        (setq d2 (distance (list (car (car ist2)) (cadr (car ist2))) (list (car inserD) (cadr inserD))))
        (setq d3 (distance (list (car (cadr ist1)) (cadr (cadr ist1))) (list (car inserD) (cadr inserD))))
        (setq d4 (distance (list (car (cadr ist2)) (cadr (cadr ist2))) (list (car inserD) (cadr inserD))))
        (setq pt1 (polar inspt (angle (list (car inserD) (cadr inserD)) (list (car (car ist1)) (cadr (car ist1)))) d1))
        (setq pt2 (polar inspt (angle (list (car inserD) (cadr inserD)) (list (car (car ist2)) (cadr (car ist2)))) d2))
        (setq pt3 (polar inspt (angle (list (car inserD) (cadr inserD)) (list (car (cadr ist1)) (cadr (cadr ist1)))) d3))
        (setq pt4 (polar inspt (angle (list (car inserD) (cadr inserD)) (list (car (cadr ist2)) (cadr (cadr ist2)))) d4))
        (setq str1 (substr height 1 (vl-string-search "." height)))
        (setq str2 (substr height (+ 2 (vl-string-search "." height))))
        (entmake (list '(0 . "INSERT") '(100 . "AcDbEntity") '(100 . "AcDbBlockReference") '(66 . 1) (cons 2 "GC200") (cons 10 inspt) (cons 41 scale) (cons 42 scale) (cons 43 scale) '(-3 ("SOUTH" (1000 . "186400")))))
        (entmake (list '(0 . "ATTRIB") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 10 pt2) (cons 40 (car txth)) (cons 1 str1) (cons 2 "integer") (cons 70 2) (cons 50 0) (cons 41 0.8) (cons 51 0) (cons 7 "HZ") (cons 71 0) (cons 72 2) (cons 74 1) (cons 11 pt1) '(-3 ("SOUTH" (1000 . "186411")))))
        (entmake (list '(0 . "ATTRIB") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 10 pt4) (cons 40 (car txth)) (cons 1 str2) (cons 2 "decimal") (cons 70 2) (cons 50 0) (cons 41 0.8) (cons 51 0) (cons 7 "HZ") (cons 71 0) (cons 72 0) (cons 74 1) (cons 11 pt3) '(-3 ("SOUTH" (1000 . "186412")))))
      )
    )
  )
  ;;;结束标志
  (entmake '((0 . "SEQEND")))
  (princ)
)
;;;by Gu_xl







(defun gxl-cs:gcd (inspt height scale xsws / pt blkdef obj)
  (setvar "CMDECHO" 0)
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
  (if height
    (setq height (rtos height 2 3))
    (setq height "")
  )
  (regapp "SOUTH")
  ;;;检查字体 "HZ" 是否存在
  (if (not (tblobjname "style" "HZ"))
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
  )
  ;;;检查是否存在高程点图块定义
  (if (not (tblobjname "block" "GC200"))
    (progn
      (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
      (setq obj
        (vla-AddPolyline
           blkdef
           (vlax-make-variant
              (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 5))
                 '(-0.2 0 0 0.2 0 0)
              )
           )
        )
      )
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
      (vla-put-Closed obj :vlax-true)
      (vla-put-ConstantWidth obj 0.4)
    )
  )
  ;;;插入块
  (entmake (list
             '(0 . "INSERT")
             '(100 . "AcDbEntity")
             '(100 . "AcDbBlockReference")
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随
              (cons 2 "GC200")
              (cons 10 inspt)
              (cons 41 scale)
              (cons 42 scale)
              (cons 43 scale)
              '(-3 ("SOUTH" (1000 . "202101")))
           )
  )
  ;;;插入属性
  (entmake (list
             '(0 . "ATTRIB")
             '(100 . "AcDbEntity")
             '(100 . "AcDbText")
              (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
              (cons 40 (* 2.0 scale))
              (cons 50 0)
              (cons 41 0.8)
              (cons 51 0)
              (cons 1 height)
              (cons 7 "HZ")
              (cons 72 0)
              (cons 11 pt)
              '(100 . "AcDbAttribute")
              (cons 2 "height")
              (cons 70  0)
              (cons 74 2)
           )
   )
   ;;;结束标志
   (entmake '((0 . "SEQEND")))
   (princ)
)


(defun addgcptinpm (pt lst / an anl i L n p1 p2 plst ret vlst)
  (setq n 0 L (length lst))
  (while (< n L)
    (setq vlst (car lst))
    (setq i -1
          p1 (last vlst)
    )
    (while (and (not ret) (setq p2 (nth (setq i (1+ i)) vlst)))
      (cond
        ((equal p2 pt 1e-4) (setq ret t))
        (t
          (setq an (- (angle pt p1) (angle pt p2)))
          (if (equal pi (abs an) 1e-4)
            (setq ret t)
            (setq anl (cons (rem an pi) anl))
          )
        )
      )
      (setq p1 p2)
    )
    (cond
      (ret (setq plst (list pt vlst))) ;线上;
      (t
        (if (equal pi (abs (apply '+ anl)) 1e-4)
          (setq plst (list pt vlst)) ;三角网内
          nil ;外
        )
      )
    )
    (setq n (1+ n))
    (setq lst (cdr lst))
    (if plst (setq n L))
  )
  plst
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(while (setq pt (getpoint "\n内插高程点"))
                    (setq pt (list (car pt) (cadr pt)))
                    ;;角度法判断点在那个三角形 返回((ptx pty ptz) ((p1x p1y p1z) (p2x p2y p2z) (p3x p3y p3z)))
                    (setq ptlst (addgcptinpm pt sjwlst))
                    (if ptlst ;如果点在三角形线上或三角形内
                      (progn
                        ;;双线性内插计算内插点的高程值 返回内插点(x y z)
                        (setq zpt (zInsert ptlst))
                        (print zpt)
                        ;(Entmakegcd 插入点 高程 图块比例 属性 文字字符 文字插入点 小数位数)
                        (Entmakegcd zpt (caddr zpt) Scale inserD Tag txt ist1 txth ist2 xsws)
                      )
                    )
                  )















  )

树櫴希德

几乎全是盗用程序，GZXL见谅

树櫴希德

内插高程点
内插高程点
(49945.7 17559.9 5.36899)
内插高程点
内插高程点
(49948.1 17562.9 5.34369)
内插高程点
(49956.2 17568.2 5.68597)
内插高程点
(49949.7 17565.2 5.39)
内插高程点
(49954.8 17572.5 5.8618)
内插高程点
(49951.0 17582.0 6.34998)
内插高程点
(49951.7 17584.1 6.65813)
内插高程点

树櫴希德

效果如上，高人修改吧

ZZXXQQ

树櫴希德 发表于 2014-5-15 21:17
效果如上，高人修改吧

改啥？

树櫴希德

z自己改了一下

树櫴希德

欢迎下载 修改（测试图）

树櫴希德

大家都看看就走了，没有什么留言。

gzxl

顶一个，lisp源码本来就是你用我的，我用你的，最关键是会自己改、会与别人分享学习，那才是重要
不过里面的双线性内插计算内插高程值有误（会出现除数为零）

树櫴希德

双线性内插计算内插高程值是对的啊，看图：黄色为展点，红色为加的点