根据南方cass高程点 内插高程点

yanshengjiang

预祝大家双节快乐

一段东拼西凑的代码搞到半夜3点还没完善好，那就先放个动图吧.  缺的函数见本论坛。

1. (defun c:tt (/ *error*)
   
2.   (vl-load-com)  ; 确保加载VLCOM支持
   
3.   (defun *error*(msg)
   
4.     (if en(entdel en))
   
5.     (if sq-en(entdel sq-en))
   
6.     (sssetfirst nil nil)
   
7.     (setvar 'PICKBOX old-PICKBOX)
   
8.    (princ)
   
9.     )
   
10.   (setq old-PICKBOX(getvar 'PICKBOX ))
    
11.   (setvar 'PICKBOX 0)
    
12.   (setq en (mktext "测试" '(0 0 0) 2 0 "hz" "ZJ" "ML"))
    
13.   (setq sq-en (EntmakeSquare '(0 0 0) 10))  ; 创建初始正方形并保存图元名
    
14.   (setq done nil)
    
15.   (setq gr 0 gr-model 0 gr-value 0)
    
16.   (while (not done)
    
17.     (setq gr (grread T 8 3)   ; 启用追踪
    
18.           gr-model (car gr)   
    
19.           gr-value (cadr gr))
    
20.     (cond
    
21.     ((= gr-model 5)
    
22.      
    
23.         ; 更新文字位置和内容
    
24. 
    
25.         ; 移动正方形到新位置
    
26.         
    
27.   (sssetfirst nil(setq ss(ssget "c" (list(nth 6 new-pts)(nth 7 new-pts)) (list(nth 2 new-pts)(nth 3 new-pts)) '((2 . "GC200")))))
    
28. ;;;  (princ"\n")
    
29. ;;;  (princ(setq sjw-lst(sjwlst ss)))
    
30.         (setq sjw-lst(sjwlst ss))
    
31.         (移动正方形 sq-en gr-value 100)
    
32.         (vla-put-textalignmentpoint (vlax-ename->vla-object en) (vlax-3d-point(mapcar '+ '(2 2 0) gr-value)))
    
33.      (if(setq nnn(addgcptinpm gr-value sjw-lst))
    
34.        (progn
    
35.        (setq nnn (zInsert nnn))
    
36.         (vla-put-textstring (vlax-ename->vla-object en) (vl-princ-to-string (caddr nnn)))
    
37.        )
    
38.       (vla-put-textstring (vlax-ename->vla-object en) "nil")
    
39.        )
    
40.        );
    
41.     ((= gr-model 3)
    
42.        ;; 实时显示坐标，\r 使光标回到行首实现原地更新
    
43. ;;;       (princ gr-value)
    
44. ;;;       (setq done T)
    
45.        ;; 这里可以添加实时更新的图形逻辑，例如拖拽对象、动态绘制等
    
46.      (princ"\n")
    
47.        (setq ptlst(addgcptinpm gr-value sjw-lst))
    
48.      (if ptlst ;如果点在三角形线上或三角形内
    
49.                       (progn
    
50.                         ;;双线性内插计算内插点的高程值 返回内插点(x y z)
    
51.                         (setq zpt (zInsert ptlst))
    
52.       (print zpt)
    
53.                         ;(Entmakegcd 插入点 高程 图块比例 属性 文字字符 文字插入点 小数位数)
    
54.                         ;(Entmakegcd zpt (caddr zpt) Scale inserD Tag txt ist1 txth ist2 xsws)
    
55.       
    
56. (gxl-cs:gcd zpt (caddr zpt) 1 2 );展高程点
    
57. 
    
58. 
    
59.       
    
60.                       )
    
61.                     )
    
62.      
    
63.       )
    
64.       
    
65.       ;; 代码 11：辅助设备按键（通常对应鼠标右键）
    
66.       ((= gr-model 11)
    
67.        (princ "\n检测到鼠标右键事件，退出程序。")
    
68.        (setq done T)
    
69.       )
    
70.       
    
71.   )
    
72. )
    
73.   (princ)
    
74.   )

(defun c:tt (/ *error*)<br />   (vl-load-com)  ; 确保加载VLCOM支持<br />   (defun *error*(msg)<br />     (if en(entdel en))<br />     (if sq-en(entdel sq-en))<br />     (sssetfirst nil nil)<br />     (setvar 'PICKBOX old-PICKBOX)<br />    (princ)<br />     )<br />   (setq old-PICKBOX(getvar 'PICKBOX ))<br />   (setvar 'PICKBOX 0)<br />   (setq en (mktext "测试" '(0 0 0) 2 0 "hz" "ZJ" "ML"))<br />   (setq sq-en (EntmakeSquare '(0 0 0) 10))  ; 创建初始正方形并保存图元名<br />   (setq done nil)<br />   (setq gr 0 gr-model 0 gr-value 0)<br />   (while (not done)<br />     (setq gr (grread T 8 3)   ; 启用追踪<br />           gr-model (car gr)   <br />           gr-value (cadr gr))<br />     (cond<br />     ((= gr-model 5)<br />      <br />         ; 更新文字位置和内容<br /> <br />         ; 移动正方形到新位置<br />         <br />   (sssetfirst nil(setq ss(ssget "c" (list(nth 6 new-pts)(nth 7 new-pts)) (list(nth 2 new-pts)(nth 3 new-pts)) '((2 . "GC200")))))<br /> ;;;  (princ"\n")<br /> ;;;  (princ(setq sjw-lst(sjwlst ss)))<br />         (setq sjw-lst(sjwlst ss))<br />         (移动正方形 sq-en gr-value 100)<br />         (vla-put-textalignmentpoint (vlax-ename->vla-object en) (vlax-3d-point(mapcar '+ '(2 2 0) gr-value)))<br />      (if(setq nnn(addgcptinpm gr-value sjw-lst))<br />        (progn<br />        (setq nnn (zInsert nnn))<br />         (vla-put-textstring (vlax-ename->vla-object en) (vl-princ-to-string (caddr nnn)))<br />        )<br />       (vla-put-textstring (vlax-ename->vla-object en) "nil")<br />        )<br />        );<br />     ((= gr-model 3)<br />        ;; 实时显示坐标，\r 使光标回到行首实现原地更新<br /> ;;;       (princ gr-value)<br /> ;;;       (setq done T)<br />        ;; 这里可以添加实时更新的图形逻辑，例如拖拽对象、动态绘制等<br />      (princ"\n")<br />        (setq ptlst(addgcptinpm gr-value sjw-lst))<br />      (if ptlst ;如果点在三角形线上或三角形内<br />                       (progn<br />                         ;;双线性内插计算内插点的高程值 返回内插点(x y z)<br />                         (setq zpt (zInsert ptlst))<br />       (print zpt)<br />                         ;(Entmakegcd 插入点 高程 图块比例 属性 文字字符 文字插入点 小数位数)<br />                         ;(Entmakegcd zpt (caddr zpt) Scale inserD Tag txt ist1 txth ist2 xsws)<br />       <br /> (gxl-cs:gcd zpt (caddr zpt) 1 2 );展高程点<br /> <br /> <br />       <br />                       )<br />                     )<br />      <br />       )<br />       <br />       ;; 代码 11：辅助设备按键（通常对应鼠标右键）<br />       ((= gr-model 11)<br />        (princ "\n检测到鼠标右键事件，退出程序。")<br />        (setq done T)<br />       )<br />       <br />   )<br /> )<br />   (princ)<br />   )

yanshengjiang

luzhmu 发表于 2025-9-29 08:29
三角网内插么？

根据greed鼠标位置创建矩形高程点选择集、得到三角网点表、判断在哪个三角形内、重心坐标插值法求点在面的投影高程
大概这几个步骤

yanshengjiang

测试过程中发现被广泛引用的zInsert函数有个bug，就是当三角形有一边在竖直方向上的时候，会出现除数为0的错误。需要先判断除数为0的时候 直接给ZL赋值

或者用下面这个deep seek代码代替这个功能，我简单测试这个函数是没有问题的，不知道到底对不对。

2. ;重心坐标插值法   代替双线性内插  避免垂足三角网发生除数为0的错误
   
3. (defun 重心坐标插值法求点在面的投影高程 (lst / p a b c denom lambda1 lambda2 lambda3 h)
   
4.   (setq p(car lst)
   
5.         a(car(cadr lst))
   
6.         b(cadr(cadr lst))
   
7.         c(caddr(cadr lst)))
   
8.   (setq denom (+ (* (- (cadr B) (cadr C)) (- (car A) (car C)))
   
9.                  (* (- (car C) (car B)) (- (cadr A) (cadr C)))))
   
10.   
    
11.   (setq lambda1 (/ (+ (* (- (cadr B) (cadr C)) (- (car P) (car C)))
    
12.                       (* (- (car C) (car B)) (- (cadr P) (cadr C))))
    
13.                  denom))
    
14.   
    
15.   (setq lambda2 (/ (+ (* (- (cadr C) (cadr A)) (- (car P) (car C)))
    
16.                       (* (- (car A) (car C)) (- (cadr P) (cadr C))))
    
17.                  denom))
    
18.   
    
19.   (setq lambda3 (- 1 lambda1 lambda2))
    
20.   
    
21.   ; 计算点P的高程
    
22.   (setq h(+ (* lambda1 (caddr A))
    
23.      (* lambda2 (caddr B))
    
24.      (* lambda3 (caddr C))))
    
25.   (list(car(car lst))(cadr(car lst))h)
    
26. )

;重心坐标插值法   代替双线性内插  避免垂足三角网发生除数为0的错误<br /> (defun 重心坐标插值法求点在面的投影高程 (lst / p a b c denom lambda1 lambda2 lambda3 h)<br />   (setq p(car lst)<br />         a(car(cadr lst))<br />         b(cadr(cadr lst))<br />         c(caddr(cadr lst)))<br />   (setq denom (+ (* (- (cadr B) (cadr C)) (- (car A) (car C))) <br />                  (* (- (car C) (car B)) (- (cadr A) (cadr C)))))<br />   <br />   (setq lambda1 (/ (+ (* (- (cadr B) (cadr C)) (- (car P) (car C))) <br />                       (* (- (car C) (car B)) (- (cadr P) (cadr C)))) <br />                  denom))<br />   <br />   (setq lambda2 (/ (+ (* (- (cadr C) (cadr A)) (- (car P) (car C))) <br />                       (* (- (car A) (car C)) (- (cadr P) (cadr C)))) <br />                  denom))<br />   <br />   (setq lambda3 (- 1 lambda1 lambda2))<br />   <br />   ; 计算点P的高程<br />   (setq h(+ (* lambda1 (caddr A)) <br />      (* lambda2 (caddr B)) <br />      (* lambda3 (caddr C))))<br />   (list(car(car lst))(cadr(car lst))h)<br /> )

yanshengjiang

根据高程点内插高程点 最终效果

你有种再说一遍

框选范围选中+动态拖框?
有什么意义吗?

Bao_lai

你有种再说一遍 发表于 2025-9-27 03:15
框选范围选中+动态拖框?
有什么意义吗?

我惊Σ( ° △ °|||)︴也值夜班么

chenlianghuai

用不到，顶下，头像很别致

lileiaj

半夜写代码？？？

Dea25

高程点不应该是现场实测出来的吗？内插疑是偷工，

yanshengjiang

你有种再说一遍 发表于 2025-9-27 03:15
框选范围选中+动态拖框?
有什么意义吗?

大佬也睡的晚啊

动态只是方便看看内插的高程点是怎么计算得来的

花里胡哨的，同事看了会觉得很吊

qifeifei

OKOK
非常感谢分享

不一样地设计

感谢分享。  

luzhmu

三角网内插么？