南方cass高程点加常数or修改小数位数 lsp源码
本帖最后由 yanshengjiang 于 2024-7-18 16:10 编辑混迹明经十余年，没有认真学习，至今都只能东拼西凑。
今天没事把以前用autolisp写的程序用VL函数重写了一次:lol
(defun c:tt(/ *error* _startundo _endundo acdoc ss i tt len s b h id)
;照搬 lee-mac的出错函数和undo标记，不知其所以然，也不知道对不对。
(defun *error* (msg)
(if acdoc
(_endundo acdoc)
)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(defun _startundo (doc)
(_endundo doc)
(vla-StartUndoMark doc)
)
(defun _endundo (doc)
(while (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
;2024年7月18日 yanshengjiang 于g103.97695700,30.72349432
(princ"\n南方cass高程点加常数or修改小数位数.建议先执行一次cass命令：根据注记修改高程。")
;(vl-catch-all-apply
; '(lambda()
(setq ss(ssget '((2 . "gc200")(8 . "GCD")))
i -1)
(setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么直接回车+0 <0>"))
(if(null tt)(setq tt 0))
(setq len(getint"\n输入要保留的小数位数<2>"))
(if(null len)(setq len 2))
(_startundo acdoc)
(repeat(sslength ss)
(setq s(vlax-ename->vla-object(ssname ss(setq i(1+ i)))))
;高程点的一些操作，源自明经通道
(if (= (vla-Get-ObjectName s) "AcDbBlockReference")
(if (vla-Get-HasAttributes s)
(progn
(setq b(nth 0(vlax-safearray->list (vlax-variant-value(vla-GetAttributes s)))))
(setq h(read(vla-get-TextString b)));高程点块的属性值333.03
(setq id(vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint s))));块的三维插入点(10.9191 10.7323 333.032)
(if(equal h (last id) 1e-1)(setq h(last id)));如果属性和Z值一样，就用z值来加减，防止损失毫米位精度
(setq h(+ tt h))
(setq id(list(car id)(cadr id) h))
(vla-put-insertionpoint s (vlax-3D-point id)) ;改变块的插入点
(vla-put-TextString b (rtos h 2 len))
)
)
)
)
(_endundo acdoc)
;))
(prin1)
)
这是以前的版本：
;2011年12月11日 02:31:31 BY yanshengjiang
;于贵州晴隆
(defun c:gcd(/ tt ss i s snext data old new len);高程加常数
(princ"\n南方cass高程点加常数 or 修改小数位数.建议先执行一次cass命令：根据注记修改高程。")
(vl-catch-all-apply
'(lambda()
(if(setq s(ssget "x" '((2 . "gc200")) ))
(if(setq ss(ssget '((2 . "gc200")) ))
(progn
(initget 1)
(setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么就输入0>>>"))
(initget 1)
(setq len(fix(getreal "\n输入要保留的小数位数>>>")))
(command "undo" "be")
(setqi 0)
(while (< i (sslength ss))
(vl-catch-all-apply
'(lambda()
(setq s(Ssname ss i))
(setq snext(entnext s))
(setq data(entget snext))
;;;(setq old (read(cdr(assoc 1 data))));调用属性值改1位后不能再改两位
(SETQ old(last(assoc 10(entget s))));调用块插入点z坐标 而非属性值
(setq new (+ tt old))
(setq data(subst(cons 1 (rtos new 2 len)) (assoc 1 data) data))
(if(/= tt 0)
(progn
(setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))
(setq data(subst(mapcar '+ (assoc 11 data) (list 0 0 0 tt)) (assoc 11 data) data))
))
(entmod data);修改位数
(if(/= tt 0)
(progn
(setq data(entget s '("*")))
(setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))
(entmod data)
));如果要修改值
(entupd s);更新显示
));出错处理2：如果有些gcd层的块没有高程属性，那么跳过这个并继续下一个
(setq i (1+ i))
(princ "\r已完成 ")
(princ (rtos (/ i (sslength ss) 0.01) 2 1))
(princ " %.")
(princ)
) ;while
(command "undo" "e")
));if progn
(alertt "没有找到GCD图层的块" 1 "CASS助手提示你" 48)
)));if vl-catch出错处理1：静默所有出错提示
(princ)
)
本帖最后由 你有种再说一遍 于 2024-7-18 11:56 编辑
yanshengjiang 发表于 2024-7-18 11:21
测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。
自从我知道有一个叫十亿行天文台数据挑战,我就觉得超过2秒的功能,真的好慢 gzxl 发表于 2024-7-18 20:20
lisp 测试时间，不管是 autolisp，还是 vl
尽量代码简化，同等的条件下。
我知道本来 repeat nth 就耗费 ...
要while要好些哇我试试 测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。 你有种再说一遍 发表于 2024-7-18 11:44
自从我知道有一个叫十亿行天文台数据挑战,我就觉得超过2秒的功能,真的好慢
:lol大神的眼界果然不同 czb203 发表于 2024-7-18 18:52
大神的眼界果然不同
不说你们不转来c#,嘿嘿 本帖最后由 gzxl 于 2024-7-18 20:24 编辑
lisp 测试时间，不管是 autolisp，还是 vl
尽量代码简化，同等的条件下。
我知道本来 repeat nth 就耗费时间，这很早就测试过了
不要加入 error command 等相关的代码
源码分享 必顶 yanshengjiang 发表于 2024-7-18 11:21
测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。
那不是白写了。 坐标暴露了，MG的导弹已锁定，快逃。
页:
[1]
2