我想要这个程序
不谋而合，该怎么办啊
很好，可惜要币
好东西，但是没有明经币了
测量成图剖面计算 有个 横剖面计算
下载地址 pmq.ys168.com
用的吧，不过收费500，嘿嘿，有点贵，却值得，无论多少数据，一键搞定，呵呵，QQ58635053
这么多人有兴趣啊(defun c:dmcj ( / a b curve dislst dist ele file filename fistdist fistgcd fistpt gcdz i ispt lst msg name nn ob ob_pl obj
objname osmode p1 p2 p3 p4 pathname pl pl1 points pt ptlst ss startpt str textstring use v xx zxd)
;;;高程点按曲线进行排序
(defun dmcj_gcdsort (points curve / pl1 xx nn)
(if (= (type curve) 'ENAME) (setq curve (vlax-ename->vla-object curve)))
(setq pl1 (mapcar '(lambda (xx /) (vlax-curve-getParamAtPoint curve (vlax-curve-getClosestPointTo curve xx))) points))
(mapcar '(lambda (nn) (nth nn points)) (vl-sort-i pl1 '<))
)
(defun dmcj_getstr (pt use / a b dislst dist i ispt lst Name ob obj p1 p2 p3 p4 textstring)
(setq p1 (polar pt 3.92699 (* use 0.01))
p2 (polar pt 5.49779 (* use 0.01))
p3 (polar pt 0.785398 (* use 0.01))
p4 (polar pt 2.35619 (* use 0.01))
)
(setq lst (list p1 p2 p3 p4))
(setq ob (ssget "_CP" lst (list '(-4 . "<OR") '(0 . "*TEXT") '(-4 . "OR>"))))
(cond
((= ob nil) (setq TextString ""))
((= (sslength ob) 1)
(setq TextString (Vlax-Get (vlax-ename->vla-object (ssname ob 0)) 'TextString ))
(if (or (= (substr TextString 1 1) "k") (= (substr TextString 1 1) "K")) (setq TextString ""))
)
((>= (sslength ob) 2)
(setq i 0 dislst nil)
(repeat (sslength ob)
(setq Name (ssname ob i))
(setq obj (vlax-ename->vla-object Name))
(setq isPt (Vlax-get obj 'InsertionPoint ))
(setq TextString (Vlax-Get obj 'TextString ))
(if (or (/= (substr TextString 1 1) "k") (/= (substr TextString 1 1) "K"))
(progn
(setq dist (list (distance pt isPt) TextString))
(setq dislst (cons dist dislst))
)
)
(setq i (1+ i))
)
(setq dislst (vl-sort dislst (function (lambda (a b) (< (car a) (car b))))))
(setq TextString (cadr (car dislst)))
)
)
TextString
)
(if (= (getvar "USERR1") 0.0)
(progn
(setq use (getint "\n绘图比例1:<200>"))
(if (= use nil) (setq use 200))
(setvar "USERR1" use)
)
)
(vl-load-com)
(setq use (getvar "USERR1"))
(setq osmode (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(if (setq PL (car (entsel "\n请选择断面线：")))
(progn
(setq ob_PL (vlax-ename->vla-object PL))
(setq objname (Vlax-Get ob_pl 'ObjectName ))
(setvar "osmode" 33)
(setq zxd (getpoint "\n拾取断面起点：")
zxd (list (car zxd) (cadr zxd))
)
(setvar "osmode" 0)
(cond
((= objname "AcDbLine")
(setq StartPt (Vlax-Get ob_pl 'StartPoint ))
)
((= objname "AcDbPolyline")
(setq Ele (Vlax-Get ob_pl 'Elevation ))
(cond
((/= Ele 0) (alert "请将断面线标高修改为0") (exit))
((= Ele 0)
(setq ptlst (Vlax-Get ob_pl 'Coordinates ))
(setq StartPt (list (car ptlst) (cadr ptlst) 0))
)
)
)
)
(princ "\n选择和断面线高程点")
(setq lst nil)
(if (setq i -1 ss (ssget '((0 . "INSERT") (2 . "GC200"))))
(progn
(repeat (sslength ss)
(setq Name (ssname ss (setq i (1+ i))))
(setq pt (cdr (assoc 10 (entget Name))))
(setq lst (cons pt lst))
)
(setq lst (dmcj_gcdsort lst ob_PL)) ;高程点按曲线进行排序
(setq fistgcd (car lst))
(setq fistPt (vlax-curve-getClosestPointTo ob_PL fistgcd)) ;第一个高程点垂足断面线的坐标
(setq fistdist (distance zxd fistPt)) ;第一个高程点垂足断面线上的坐标点离断面线起点的距离
(if (null **Name) (setq **Name "D:\\K0+000"))
(if (setq file (getfiled "保存数据" **Name "csv" 1))
(progn
(setq FileName (vl-filename-base file))
(setq PathName (vl-filename-directory file))
(cond
((or (= PathName "C:\\") (= PathName "D:\\") (= PathName "E:\\") (= PathName "F:\\"))
(setq msg (strcat PathName FileName))
)
((or (/= PathName "C:\\") (/= PathName "D:\\") (/= PathName "E:\\") (/= PathName "F:\\"))
(setq msg (strcat PathName "\\" FileName))
)
)
(if (null msg)
(setq msg **Name) ;_回车后的返回值
(setq **Name msg) ;_全局变量*real值，记忆为用户输入值
)
(setq file (open file "a"))
(write-line "距离,高程值,备注" file)
(foreach v lst
(setq pt (vlax-curve-getClosestPointTo ob_PL v))
(setq dist (- (vlax-curve-getDistAtPoint ob_PL pt) fistdist))
(setq gcdz (caddr v))
(setq str (dmcj_getstr (list (car pt) (cadr pt)) use)) ;注记
(write-line (strcat (rtos dist 2 3) "," (rtos gcdz 2 3)"," str) file)
)
(close file)
)
)
)
)
)
)
(setvar "osmode" osmode)
(princ)
)
谢谢gzxl 无私提供源码！
gzxl 发表于 2013-5-17 13:06 static/image/common/back.gif
这么多人有兴趣啊
要是有个动态演示更加美好
gzbccy 发表于 2013-11-29 15:40 static/image/common/back.gif
要是有个动态演示更加美好