根据设计三角网检查场地实测标高是否满足设计要求

树櫴希德 · 发表于 2016-3-9 19:15:17

本帖最后由树櫴希德于 2016-3-9 19:22 编辑

(defun vxs1 (e)
(cdr(assoc 10 (entget e)))
)
;;;;;;;;;三维多段线输出到点表
(defun c:t6 (/ fff ssa cm en ii no wjm pzx ssa1 en1 ii1 no1 pzx1 ptb ptb1 sjwlst)
;[功能] 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 cm (getvar "cmdecho"))
(setvar "cmdecho" 0)
;(setq wjm (getfiled "请指定要保存的坐标文件" "e:\" "txt" 1))
;(setq fff (open wjm "w"))
(prompt "\n 请选择设计三角网：")
(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)))
)
;;;;;;;;;;;;;========================================================
(prompt "\n 请选择实测南方CASS高程点：：")
(setq ssa1 (ssget '((0 . "insert") (8 . "gcd"))))
(setq ii1 0
no1 0
)
(repeat (sslength ssa1)
(setq en1 (ssname ssa1 ii1)
ptb1 (vxs1 en1)
pzx1 (append pzx1 (list ptb1))
ii1 (1+ ii1) )
; (setq pzx (list (car pt) (cadr pt) (caddr pt)))
)
;;;;;;;;;;;;;;==================================================
;(write-line (strcat pzx) fff)
; (close fff)
;(princ (strcat "\n坐标已存入"" wjm ""中"))
(setvar "cmdecho" cm)
(princ)
(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" "宋体"))
(command "style" "宋体" "" 0 1 0 "" "" "")
;(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 height1 scale / pt pt1 blkdef obj)
(setvar "CMDECHO" 0)
(command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" "" "")
(if height
(setq height (rtos height 2 3))
(setq height "")
)
(if height1
(setq height1 (rtos height1 2 3))
(setq height1 "")
)
(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.5 PI) (* 1.8 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 3)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "宋体")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt1 (polar pt (* -0.5 PI) (* 3.0 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 2)
(cons 41 0.8)
(cons 51 0)
(cons 1 height1)
(cons 7 "宋体")
(cons 72 0)
(cons 11 pt1)
'(100 . "AcDbAttribute")
(cons 2 "height1")
(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
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq blc (getint "\n请输入比例尺1:"))
(setvar 'userr1 blc);设置比例尺
;(setq zg (* 0.002 blc));字高
(setq scale (* 0.001 blc));缩放比例
(foreach n pzx1
;(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 (vl-remove (last n) n) 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)
(gxl-cs:gcd zpt (caddr zpt) (- (last n) (caddr zpt)) scale );展高程点
)
)
)
)
(prompt "此程序配合CAD,最好配CASS,用于检查三角网是否连接正确，如果三角网穿越坡顶、坡脚或者其他地形特征线，那么生成的高程点将与实际不符合。在基坑图中，可套上地下室外墙边线便可以清楚查询。")

(defun vxs1 (e) 
    
   (cdr(assoc 10 (entget e))) 
 
  ) 
 
 
 
;;;;;;;;;三维多段线输出到点表 
(defun c:t6 (/ fff ssa cm en ii no wjm pzx ssa1 en1 ii1 no1 pzx1 ptb ptb1 sjwlst) 
;[功能] 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 cm (getvar "cmdecho")) 
    (setvar "cmdecho" 0) 
    ;(setq wjm (getfiled "请指定要保存的坐标文件" "e:\" "txt" 1)) 
       ;(setq fff (open wjm "w")) 
  (prompt "\n 请选择设计三角网：") 
       (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))) 
                        
                  ) 
;;;;;;;;;;;;;======================================================== 
  (prompt "\n 请选择实测南方CASS高程点：：") 
  (setq ssa1 (ssget '((0 . "insert") (8 . "gcd")))) 
                (setq ii1   0 
                      no1  0 
                  ) 
                  (repeat (sslength ssa1) 
                       (setq en1 (ssname ssa1 ii1) 
                            ptb1 (vxs1 en1) 
          pzx1 (append pzx1 (list ptb1)) 
           ii1  (1+ ii1)               ) 
       ; (setq pzx (list (car pt) (cadr pt) (caddr pt))) 
                        
                  ) 
  ;;;;;;;;;;;;;;================================================== 
  ;(write-line (strcat pzx) fff) 
                 ; (close fff) 
                  ;(princ (strcat "\n坐标已存入"" wjm ""中")) 
    
    (setvar "cmdecho" cm) 
    (princ) 
 
 
 
  (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" "宋体")) 
    (command "style" "宋体" "" 0 1 0 "" "" "") 
    ;(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 height1 scale  / pt  pt1 blkdef obj) 
  (setvar "CMDECHO" 0) 
  (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (if height 
    (setq height (rtos height 2 3)) 
    (setq height "") 
  ) 
(if height1 
    (setq height1 (rtos height1 2 3)) 
    (setq height1 "") 
  ) 
   
  (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.5 PI) (* 1.8 scale)))) 
              (cons 40 (* 2.0 scale)) 
              (cons 50 0) 
               (cons 62 3) 
              (cons 41 0.8) 
              (cons 51 0) 
              (cons 1 height) 
              (cons 7 "宋体") 
              (cons 72 0) 
              (cons 11 pt) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height") 
              (cons 70  0) 
              (cons 74 2) 
           ) 
   ) 
;;;;;;;;;;;;;;;;;;;;;;; 
;;;插入属性 
  (entmake (list 
             '(0 . "ATTRIB") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbText") 
              (cons 10 (setq pt1 (polar pt (* -0.5 PI) (* 3.0 scale)))) 
              (cons 40 (* 2.0 scale)) 
              (cons 50 0) 
               (cons 62 2) 
              (cons 41 0.8) 
              (cons 51 0) 
              (cons 1 height1) 
              (cons 7 "宋体") 
              (cons 72 0) 
              (cons 11 pt1) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height1") 
              (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 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  (setq blc (getint "\n请输入比例尺1:")) 
  (setvar 'userr1 blc);设置比例尺 
  ;(setq zg (* 0.002 blc));字高 
  (setq scale (* 0.001 blc));缩放比例 
 
(foreach n pzx1 
  ;(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 (vl-remove (last n) n) 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) 
       
(gxl-cs:gcd zpt (caddr zpt) (- (last n) (caddr zpt)) scale  );展高程点 
 
 
       
                      ) 
                    ) 
                  ) 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
  ) 
 
 
 
(prompt "此程序配合CAD,最好配CASS,用于检查三角网是否连接正确，如果三角网穿越坡顶、坡脚或者其他地形特征线，那么生成的高程点将与实际不符合。在基坑图中，可套上地下室外墙边线便可以清楚查询。")

树櫴希德 · 发表于 2016-3-10 11:56:57

设计面为斜面或者不规则面用三角网好模仿设计地形

yjycad · 发表于 2016-3-19 15:14:52

不错，谢谢分享

18623643220 · 发表于 2016-3-30 14:20:32

楼主能给我下载下吗

luojie110 · 发表于 2017-11-17 16:09:02

阅读权限还不够下载不了

luojie110 · 发表于 2017-11-17 16:09:21

还是顶一下楼主的好东西

yshf · 发表于 2017-12-24 23:21:35

谢谢分享，学习学习！

技术工作室 · 发表于 2022-9-8 21:19:25

学习学习，谢谢分享

gzxl · 发表于 2022-10-9 22:05:05

本帖最后由 gzxl 于 2022-10-9 22:13 编辑

技术工作室发表于 2022-9-8 21:19
学习学习，谢谢分享

技术工作室，这名称好。

skg123 · 发表于 2023-4-5 16:26:31

这个很有创意

账号		自动登录	找回密码
密码			注册

根据设计三角网检查场地实测标高是否满足设计要求

本帖子中包含更多资源

点评

评分

相关帖子