【求助】如何在cad中生成控制点坐标表【已解决】
本帖最后由 yuanziyou 于 2018-10-3 18:49 编辑各位搞测绘的高手，谁可以帮忙编写一个在cad中生成控制点坐标表的小程序（直接生成在cad文件中）具体的样式见附件
======================================================================================
感谢gzxl提供的源代码与思路，下面是我整理后的代码，是在gzxl代码的基础上修改了提取点名的部分，表格重新调整了大小，获取的数据可以按点名排序,添加注释,方便学习,共同进步!
是在CASS下面生成的控制点的话就有办法做，， xiabin68 发表于 2012-12-12 18:49 static/image/common/back.gif
是在CASS下面生成的控制点的话就有办法做，，
就是cass，我想直接放在图上，导出到文件的倒是好解决 yuanziyou 发表于 2012-12-12 20:10 static/image/common/back.gif
就是cass，我想直接放在图上，导出到文件的倒是好解决
当练练
(defun c:tt ( / i lst lstp osm pt ss)
(vl-load-com)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(if (setq i 0 ss (ssget '((0 . "INSERT") (8 . "KZD"))))
(progn
(setq i 0 lstp '())
(repeat (sslength ss)
(setq pt (cdr (assoc 10 (entget (ssname ss i))))
lst(SearchText pt)
lstp (cons (append pt (list lst)) lstp)
i (1+ i)
)
)
(if (setq p0 (getpoint "\n指定表格绘制位置:"))
(progn
(if (null p0) (setq p0 '(0 0 0)))
(OutputHeader p0)
(Outputtable lstp p0)
)
)
)
)
(setvar "osmode" osm)
(princ)
)
(defun SearchText (p / i kzdtext ob px py pz x1 x2 y1 y2)
(setq px(car p)
py(cadr p)
pz(caddr p)
x1(- px 4)
x2(+ px 4)
y1(- py 4)
y2(+ py 4)
)
(setq ob (ssget "X" (list '(-4 . "<and") '(-4 . ">=,>=,*") (list 10 x1 y1 0) '(-4 . "<=,<=,*") (list 10 x2 y2 0) '(0 . "*TEXT") '(8 . "KZD")'(-4 . "and>"))))
(cond
((= ob nil) (setq kzdText ""))
((= (sslength ob) 1) (setq kzdText (Vlax-Get (vlax-ename->vla-object (ssname ob 0)) 'TextString )))
((>= (sslength ob) 2)
(progn
(setq i 0)
(repeat (sslength ob)
(setq kzdText (Vlax-Get (vlax-ename->vla-object (ssname ob i)) 'TextString ))
(cond
((= (ascii kzdText) 75) (setq kzdText kzdText))
;((> (ascii kzdText) 57) (setq kzdText kzdText))
((/= (ascii kzdText) 75) (setq kzdText ""))
;((<= (ascii kzdText) 57) (setq kzdText ""))
)
(setq i (1+ i))
)
)
)
)
kzdText
)
(defun OutputHeader (p0 / i k lst p0 p1 p2 p3 p4 p5 p6 ptlst strlst)
(setq p4 (polar p0 (* 0.5 pi) 6) p5 (polar p4 0 100) p6 (polar p0 0 100))
(EntmakeLine (list p0 p4 p5 p6 p0))
(EntmakeText "控制点坐标及高程成果表(单位:m)" (polar p0 (angle p0 p5) (/ (distance p0 p5) 2)))
(setq i 0 k 4 lst '() ptlst '() strlst '("点名" "北坐标(X)" "东坐标(Y)" "高程(H)"))
(while (< i k)
(setq p1 (polar p0 (* -0.5 pi) 6)
p2 (polar p0 0 25)
p3 (polar p1 0 25)
)
(EntmakeText (nth i strlst) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq lst (cons p0 (cons p1 (cons p3 (cons p2 lst))))
ptlst (append ptlst lst)
p0 p2
)
(setq i (1+ i))
)
(EntmakeLine ptlst)
)
(defun Outputtable (lsp pt / i k p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 vlst)
(setq i 0 k (length lsp) p0 (polar pt (* -0.5 pi) 6))
(repeat k
(setq vlst(nth i lsp)
p1 (polar p0 (* -0.5 pi) 6)
p2 (polar p0 0 25)
p3 (polar p1 0 25)
p4 (polar p0 0 50)
p5 (polar p4 (* -0.5 pi) 6)
p6 (polar p0 0 75)
p7 (polar p6 (* -0.5 pi) 6)
p8 (polar p0 0 100)
p9 (polar p8 (* -0.5 pi) 6)
)
(EntmakeText (cadddr vlst) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(EntmakeLine (list p0 p1 p3 p2 p0))
(EntmakeText (rtos (car vlst) 2 3) (polar p3 (angle p3 p4) (/ (distance p3 p4) 2)))
(EntmakeLine (list p2 p3 p5 p4 p2))
(EntmakeText (rtos (cadr vlst) 2 3) (polar p5 (angle p5 p6) (/ (distance p5 p6) 2)))
(EntmakeLine (list p4 p5 p7 p6 p4))
(EntmakeText (rtos (caddr vlst) 2 3) (polar p7 (angle p7 p8) (/ (distance p7 p8) 2)))
(EntmakeLine (list p6 p7 p9 p8 p6))
(setq p0 p1)
(setq i (1+ i))
)
)
(defun EntmakeText (str pt)
(entmake (list '(0 . "TEXT") (cons 1 str) (cons 10 pt) (cons 40 2.5) '(71 . 0) '(72 . 4) (cons 11 pt)))
)
(defun EntmakeLine (vertices / elist seg)
(setq elist
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
(cons 90 (length vertices)) (cons 70 0) (cons 38 (caddr (car vertices)))
)
)
(foreach seg vertices (setq elist (append elist (list (cons 10 seg) (cons 42 0)))))
(entmake elist)
)
当练练---- gzxl 发表于 2012-12-12 23:59 static/image/common/back.gif
当练练
为什么我用你的程序，生成的表格没有点名呢？？？ xiabin68 发表于 2012-12-13 13:10 static/image/common/back.gif
为什么我用你的程序，生成的表格没有点名呢？？？
(= (ascii kzdText) 75) 就是"K"
如果点名字母是其他的，需要修改 strlst '("点名" "北坐标(X)" "东坐标(Y)" "高程(H)"
换成
strlst '("点名" "东坐标(Y)" "北坐标(X)" "高程(H)"
或者
(EntmakeText (rtos (car vlst) 2 3) (polar p3 (angle p3 p4) (/ (distance p3 p4) 2)))
(EntmakeText (rtos (cadr vlst) 2 3) (polar p5 (angle p5 p6) (/ (distance p5 p6) 2)))
换成
(EntmakeText (rtos (cadr vlst) 2 3) (polar p3 (angle p3 p4) (/ (distance p3 p4) 2)))
(EntmakeText (rtos (car vlst) 2 3) (polar p5 (angle p5 p6) (/ (distance p5 p6) 2))) gzxl 发表于 2012-12-13 13:51 static/image/common/back.gif
strlst '("点名" "北坐标(X)" "东坐标(Y)" "高程(H)"
换成
strlst '("点名" "东坐标(Y)" "北坐标(X)" "高 ...
感谢提供！ yuanziyou 发表于 2012-12-13 14:14 static/image/common/back.gif
感谢提供！
忘了cass的控制点是有扩展属性的
(defun c:tt ( / i str lstp osm pt ss)
(vl-load-com)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(if (setq i 0 ss (ssget '((0 . "INSERT") (8 . "KZD"))))
(progn
(setq i 0 lstp '())
(repeat (sslength ss)
(setq pt (cdr (assoc 10 (entget (ssname ss i))))
str(XdataDh (ssname ss i))
lstp (cons (append pt (list str)) lstp)
i (1+ i)
)
)
(if (setq p0 (getpoint "\n指定表格绘制位置:"))
(progn
(if (null p0) (setq p0 '(0 0 0)))
(OutputHeader p0)
(Outputtable lstp p0)
)
)
)
)
(setvar "osmode" osm)
(princ)
)
(defun XdataDh (vlaObj / i lstAll lstSub safDXFValues safDXFValues strdh)
(if (= (type vlaObj) 'ENAME)
(setq vlaObj (vlax-ename->vla-object vlaObj))
)
(vla-getxdata vlaObj "" 'safDXFCodes 'safDXFValues)
(if (and safDXFCodes safDXFValues)
(progn
(setq lstDXFCodes (vlax-safearray->list safDXFCodes)
lstDXFValues (mapcar 'variant-value (vlax-safearray->list safDXFValues))
)
(setq i 0)
(foreach intDXFCode lstDXFCodes
(if (= intDXFCode 1001)
(if lstSub
(setq lstAll (cons (reverse lstSub) lstAll)
lstSub (list (nth i lstDXFValues))
)
(setq lstSub (list (nth i lstDXFValues)))
)
(setq lstSub (cons (nth i lstDXFValues) lstSub))
)
(setq i (1+ i))
)
(if lstSub (reverse (cons (reverse lstSub) lstAll)))
(setq strdh (car lstSub))
)
)
)
(defun OutputHeader (p0 / i k lst p0 p1 p2 p3 p4 p5 p6 ptlst strlst)
(setq p4 (polar p0 (* 0.5 pi) 6) p5 (polar p4 0 100) p6 (polar p0 0 100))
(EntmakeLine (list p0 p4 p5 p6 p0))
(EntmakeText "控制点坐标及高程成果表(单位:m)" (polar p0 (angle p0 p5) (/ (distance p0 p5) 2)))
(setq i 0 k 4 lst '() ptlst '() strlst '("点名" "北坐标(X)" "东坐标(Y)" "高程(H)"))
(while (< i k)
(setq p1 (polar p0 (* -0.5 pi) 6)
p2 (polar p0 0 25)
p3 (polar p1 0 25)
)
(EntmakeText (nth i strlst) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq lst (cons p0 (cons p1 (cons p3 (cons p2 lst))))
ptlst (append ptlst lst)
p0 p2
)
(setq i (1+ i))
)
(EntmakeLine ptlst)
)
(defun Outputtable (lsp pt / i k p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 vlst)
(setq i 0 k (length lsp) p0 (polar pt (* -0.5 pi) 6))
(repeat k
(setq vlst(nth i lsp)
p1 (polar p0 (* -0.5 pi) 6)
p2 (polar p0 0 25)
p3 (polar p1 0 25)
p4 (polar p0 0 50)
p5 (polar p4 (* -0.5 pi) 6)
p6 (polar p0 0 75)
p7 (polar p6 (* -0.5 pi) 6)
p8 (polar p0 0 100)
p9 (polar p8 (* -0.5 pi) 6)
)
(EntmakeText (cadddr vlst) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(EntmakeLine (list p0 p1 p3 p2 p0))
(EntmakeText (rtos (cadr vlst) 2 3) (polar p3 (angle p3 p4) (/ (distance p3 p4) 2)))
(EntmakeLine (list p2 p3 p5 p4 p2))
(EntmakeText (rtos (car vlst) 2 3) (polar p5 (angle p5 p6) (/ (distance p5 p6) 2)))
(EntmakeLine (list p4 p5 p7 p6 p4))
(EntmakeText (rtos (caddr vlst) 2 3) (polar p7 (angle p7 p8) (/ (distance p7 p8) 2)))
(EntmakeLine (list p6 p7 p9 p8 p6))
(setq p0 p1)
(setq i (1+ i))
)
)
(defun EntmakeText (str pt)
(entmake (list '(0 . "TEXT") (cons 1 str) (cons 10 pt) (cons 40 2.5) '(71 . 0) '(72 . 4) (cons 11 pt)))
)
(defun EntmakeLine (vertices / elist seg)
(setq elist
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
(cons 90 (length vertices)) (cons 70 0) (cons 38 (caddr (car vertices)))
)
)
(foreach seg vertices (setq elist (append elist (list (cons 10 seg) (cons 42 0)))))
(entmake elist)
)