004 发表于 2013-4-11 11:33 static/image/common/back.gif
发个关于动态生等高线的，还没弄完，先给大家看看吧，请高手提供，不用command trim的裁切算法。
要求参看 ...
大侠，试用该插件，到第二步总是失败
命令: tt1
选择高程点...
选择对象: 指定对角点: 找到 464 个
已滤除 232 个。
选择对象:
0.1720 secs.
nil nil
命令: tt2
选择对象: 指定对角点: 找到 917 个
已滤除 467 个。
选择对象:
AAAAAAAAAAAAA; 错误: 参数类型错误: consp <Selection set: 7d>
不解
这是习作，仅供交流，欢迎指正
向大师学习
有些人过分依赖CASS,这样不好的啊
本帖最后由 wmz 于 2014-9-27 13:53 编辑
004 发表于 2012-12-16 00:50 static/image/common/back.gif
Automation 错误。 安全数组中的元素太少或总元素数目不是 3 的倍数----用短线法当三角网太多时（7118个三角网）所出现的问题，少的时候没有
楼主在吗？有问题想请教
相邻边法提示"除数为0",
Automation 错误。 安全数组中的元素太少或总元素数目不是 3 的倍数----三角网为几十个时仍提示这个,没再试了
向高手学习
本帖最后由 shmily1023 于 2015-9-4 17:48 编辑
(defun mk2polyline (pts bh elev / LENN MY2DPOLY myms)
;;功能:生成二次拟合的二维多段线
;;参数:pts点表bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-16
(setqmyms (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(or (tblsearch "LAYER" "DGX")
(entmake (list '(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord"
)
'(100
.
"AcDbLayerTableRecord"
)
'(2 . "DGX")
'(70 . 0)
'(62 . 2)
'(6
.
"Continuous"
)
'(290 . 1)
'(370 . -3)
)
)
)
(setvar "CLAYER" "DGX")
(setq
pts(apply 'append
(mapcar '(lambda (x) (append x (list 0))) pts)
)
)
(setq lenn (length pts))
(if (>= lenn 6)
;;有遇到两点相同的一段线,以为是闭合去掉一点后,就创建不了线而出错.
(progn (setq
pts (vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (1- lenn))
)
pts
)
)
(setq
my2dpoly (vla-AddPolyline myms (vlax-make-variant pts))
)
<font color="red"> (vla-put-Elevation my2dpoly (/ elev 100.0)) ;_标高</font>
(if bh
(vla-put-Closed my2dpoly T) ;_闭合
)
(if (> lenn 6)
(vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
)
)
)
)
(defun bianpt (a b dgj / ANG AZ BZ DISTDT
ELEVGAOCGCNUM MAXZMINZPT PTLST TMP Y
)
(setq y t) ;_等高线是否经过
(setq az (caddr a))
(setq bz (caddr b))
(if (= bz az)
;;判断两点之间是否有指定等高距的等高线穿过
(setq y nil)
(progn (if (< (- bz az) 0)
;;使bz>az
(setq tmp az
azbz
bztmp
tmp a
a b
b tmp
)
)
(if (< (- bz az) dgj)
(if (< (- bz (rem bz dgj)) az)
(setq y nil)
)
)
)
)
(if y
;;计算此边所有等高线的穿过点
(progn (setq a (list (car a) (cadr a) 0))
(setq dist (distance a (list (car b) (cadr b))))
(setq gaoc (- bz az))
(setq ang (angle a b))
(setq minz (* (+ (fix (/ az dgj)) 1) dgj)) ;_最小Z
(setq maxz (* (fix (/ bz dgj)) dgj)) ;_最大Z
(setq gcnum (/ (- maxz minz) dgj)) ;_高差算出等高线数量
(setq elev minz) ;_从最小的高程画起
(setq dt (* dist (/ (- elev az) gaoc)))
(setq pt (polar a ang dt))
(setq pt (list (car pt) (cadr pt)))
(setq ptlst (append ptlst (list (list elev pt))))
(setq dt (* dist (/ dgj gaoc)))
<font color="red">(repeat (fix gcnum)</font>
(setq elev (+ elev dgj))
(setq pt (polar pt ang dt))
(setq pt (list (car pt) (cadr pt)))
(setq ptlst (append ptlst (list (list elev pt))))
)
)
)
(setq ptlst ptlst)
)
(print "tt2选三角网生等高线")
(defun c:tt2 (/ A ABLSTB BB BCLST BHC CALST
DGJ E ELEVGELEVGLST END FLFUN FX
G I JOLEN LINELINELSTN NN
ONE PTLST QSISJXDD SS START TITIMETWO
XH
)
(command ".undo" "end")
(command ".undo" "begin")
(if (setq ss (ssget '((0 . "POLYLINE") (8 . "SJW"))))
(progn
(setq ti (car (_VL-TIMES))) ;_获得程序开始时间
(foreach elevg elevglst
(set (read elevg) nil)
)
(setq elevglst nil)
(setq dgj (getreal "请输入等高距（米）")) ;_等高距
(setq i -1)
(repeat (sslength ss)
(setq e (ssname ss (setq i (+ 1 i))))
(setq sjxdd (funsjxdd e))
(setq a (car sjxdd))
(setq b (cadr sjxdd))
(setq c (caddr sjxdd))
(setq ablst (bianpt a b dgj))
(setq bclst (bianpt b c dgj))
(setq calst (bianpt c a dgj))
(setq ptlst '())
(setq ptlst (append ptlst ablst bclst calst))
(while ptlst
;;将此三角形三边等高线的穿过点整理成小短线,并加入同高名变量表
(setq bb (rem (length ptlst) 2))
(setq one (car ptlst))
(setq G (car one))
(setq ptlst (cdr ptlst))
(setq two (assoc G ptlst))
(setq ptlst (vl-remove two ptlst))
(setq one (cadr one))
(setq two (cadr two))
<font color="red">(setq elevg (strcat "G" (rtos (* G 100) 2 0) ))</font>
;;创建符号名为elevg的表,或在elevg表的尾部加上此段线
(if (member elevg elevglst)
(set (read elevg)
(append (eval (read elevg))
(list (list one two) (list two one))
)
)
(progn
(set (read elevg) (list (list one two) (list two one)))
(setq elevglst (append elevglst (list elevg))) ;_将此高加入等值线变量名表
)
)
)
)
;;依次取出等值线变量名表
(foreach elevg elevglst
(setq g (atof (substr elevg 2))) ;_高程值
(setq linelst (eval (read elevg))) ;_等值短线表
(setq len (length linelst))
(setq a nil)
(setq b nil)
;;短线按x坐标排序,x相同,用y坐标排
(setq nn (vl-sort-i linelst
(function (lambda (a b)
(setq ax (caar a))
(setq ay (cadar a))
(setq bx (caar b))
(setq by (cadar b))
(if (equal ax bx 0.001)
(if (equal ay by 0.001)
T
(if(< ay by)
T
nil
)
)
(if (< ax bx)
T
nil
)
)
)
)
)
)
(setq ptlst '())
(setq qsi 0)
;;同一高程的等高线有三种情况的组合,
;;1.单条2.闭合,3.多条
(while (setq n (nth qsi nn))
(setq i qsi)
(setq line (nth n linelst))
(setq ptlst line)
(setq jo (rem n 2))
(setq nn (subst -1 n nn))
(setqnn (subst -1
(if (= 0 jo)
(1+ n)
(1- n)
)
nn
)
)
(setq start (car line))
(setq end (cadr line))
(while (= -1 (nth i nn)) (setq i (1+ i)))
(setq xh T)
;;确定搜索方向
(setqfx 1
fun >
)
(while (and xh (setq n (nth i nn)))
(setq two (nth n linelst))
(if(equal end (car two) 0.001)
(progn (setq n (nth i nn))
(setq nn (subst -1 n nn))
(setq jo (rem n 2)
nn (subst-1
(if (= 0 jo)
(1+ n)
(1- n)
)
nn
)
ptlst (append ptlst (list (cadr two)))
start (car two)
end (cadr two)
)
(if (> (car end) (car start))
(setq fx1
fun >
)
(setq fx-1
fun <
)
)
)
(if (fun (car end) (caar two))
(setq i (+ i fx))
(setq xh nil)
)
)
(while (and (/= -1 i) (= -1 (nth i nn))) (setq i (+ i fx)))
(if(= i -1)
(setq xh nil)
)
)
(if ptlst
(progn (if (equal (car ptlst) (last ptlst) 0.001)
;;判断闭合
(setq bh T
ptlst (cdr ptlst)
)
(setq bh nil)
)
(mk2polyline ptlst bh g)
(setq ptlst '())
)
)
(setq i qsi)
(while (= -1 (nth i nn)) (setq i (1+ i)))
(setq qsi i)
)
)
;;清空定义的序列变量
(foreach elevg elevglst (set (read elevg) nil))
(setq elevglst nil)
(setq time (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
) ;_计算程序耗时
(princ time)
)
)
(command ".undo" "end")
(princ)
) ;_程序完毕
本帖最后由 shmily1023 于 2015-9-4 17:49 编辑
(read elevg) read不好
（read "G5.50"） 返回 G5
(read "G5")返回G5
只好用本办法放大100倍