南方cass高程点加常数or修改小数位数 lsp源码

yanshengjiang

混迹明经十余年，没有认真学习，至今都只能东拼西凑。

今天没事把以前用autolisp写的程序用VL函数重写了一次

1. (defun c:tt(/ *error* _startundo _endundo acdoc ss i tt len s b h id)
   
2.   ;照搬 lee-mac的出错函数和undo标记，不知其所以然，也不知道对不对。
   
3.     (defun *error* (msg)
   
4.     (if        acdoc
   
5.       (_endundo acdoc)
   
6.     )
   
7.     (or        (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
   
8.         (princ (strcat "\n** Error: " msg " **"))
   
9.     )
   
10.     (princ)
    
11.   )
    
12. 
    
13.   (defun _startundo (doc)
    
14.     (_endundo doc)
    
15.     (vla-StartUndoMark doc)
    
16.   )
    
17. 
    
18.   (defun _endundo (doc)
    
19.     (while (= 8 (logand 8 (getvar 'UNDOCTL)))
    
20.       (vla-EndUndoMark doc)
    
21.     )
    
22.   )
    
23. 
    
24.   (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
    
25.   
    
26.   ;2024年7月18日 yanshengjiang 于g103.97695700,30.72349432
    
27.   (princ"\n南方cass高程点加常数or修改小数位数.建议先执行一次cass命令：根据注记修改高程。")
    
28.     ;(vl-catch-all-apply
    
29.    ; '(lambda()
    
30.   (setq ss(ssget '((2 . "gc200")(8 . "GCD")))
    
31.   i -1)
    
32.   (setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么直接回车+0 <0>"))
    
33.   (if(null tt)(setq tt 0))
    
34.   (setq len(getint  "\n输入要保留的小数位数<2>"))
    
35.   (if(null len)(setq len 2))
    
36.   (_startundo acdoc)
    
37.   (repeat(sslength ss)
    
38.     (setq s(vlax-ename->vla-object(ssname ss(setq i(1+ i)))))
    
39.     ;高程点的一些操作，源自明经通道
    
40.     (if (= (vla-Get-ObjectName s) "AcDbBlockReference")
    
41.       (if (vla-Get-HasAttributes s)
    
42.   (progn
    
43.     (setq b(nth 0(vlax-safearray->list (vlax-variant-value(vla-GetAttributes s)))))
    
44.           (setq h(read(vla-get-TextString b)))  ;高程点块的属性值  333.03
    
45.           (setq id(vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint s))));块的三维插入点  (10.9191 10.7323 333.032)
    
46.           (if(equal h (last id) 1e-1)(setq h(last id)));如果属性和Z值一样，就用z值来加减，防止损失毫米位精度
    
47.           (setq h(+ tt h))
    
48.           (setq id(list(car id)(cadr id) h))
    
49.           (vla-put-insertionpoint s (vlax-3D-point id)) ;改变块的插入点
    
50.           (vla-put-TextString b (rtos h 2 len))
    
51.           )
    
52.   )
    
53.       )
    
54.     )
    
55.   (_endundo acdoc)
    
56.      ;  ))
    
57.   (prin1)
    
58.   )
    
59. 
    

(defun c:tt(/ *error* _startundo _endundo acdoc ss i tt len s b h id)<br />   ;照搬 lee-mac的出错函数和undo标记，不知其所以然，也不知道对不对。<br />     (defun *error* (msg)<br />     (if        acdoc<br />       (_endundo acdoc)<br />     )<br />     (or        (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")<br />         (princ (strcat "\n** Error: " msg " **"))<br />     )<br />     (princ)<br />   )<br /> <br />   (defun _startundo (doc)<br />     (_endundo doc)<br />     (vla-StartUndoMark doc)<br />   )<br /> <br />   (defun _endundo (doc)<br />     (while (= 8 (logand 8 (getvar 'UNDOCTL)))<br />       (vla-EndUndoMark doc)<br />     )<br />   )<br /> <br />   (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))<br />   <br />   ;2024年7月18日 yanshengjiang 于g103.97695700,30.72349432<br />   (princ"\n南方cass高程点加常数or修改小数位数.建议先执行一次cass命令：根据注记修改高程。")<br />     ;(vl-catch-all-apply<br />    ; '(lambda()<br />   (setq ss(ssget '((2 . "gc200")(8 . "GCD")))<br />   i -1)<br />   (setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么直接回车+0 <0>"))<br />   (if(null tt)(setq tt 0))<br />   (setq len(getint  "\n输入要保留的小数位数<2>"))<br />   (if(null len)(setq len 2))<br />   (_startundo acdoc)<br />   (repeat(sslength ss)<br />     (setq s(vlax-ename->vla-object(ssname ss(setq i(1+ i)))))<br />     ;高程点的一些操作，源自明经通道<br />     (if (= (vla-Get-ObjectName s) "AcDbBlockReference")<br />       (if (vla-Get-HasAttributes s)<br />   (progn<br />     (setq b(nth 0(vlax-safearray->list (vlax-variant-value(vla-GetAttributes s)))))<br />           (setq h(read(vla-get-TextString b)))  ;高程点块的属性值  333.03<br />           (setq id(vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint s))));块的三维插入点  (10.9191 10.7323 333.032)<br />           (if(equal h (last id) 1e-1)(setq h(last id)));如果属性和Z值一样，就用z值来加减，防止损失毫米位精度<br />           (setq h(+ tt h))<br />           (setq id(list(car id)(cadr id) h))<br />           (vla-put-insertionpoint s (vlax-3D-point id)) ;改变块的插入点<br />           (vla-put-TextString b (rtos h 2 len))<br />           )<br />   )<br />       )<br />     )<br />   (_endundo acdoc)<br />      ;  ))<br />   (prin1)<br />   )<br /> <br />

yanshengjiang

这是以前的版本：

1. ;2011年12月11日 02:31:31 BY yanshengjiang
   
2. ;于贵州晴隆                              
   
3. (defun c:gcd(/ tt ss i s snext data old new len);高程加常数
   
4.   (princ"\n南方cass高程点加常数 or 修改小数位数.建议先执行一次cass命令：根据注记修改高程。")
   
5.   (vl-catch-all-apply
   
6.     '(lambda()
   
7.   (if(setq s(ssget "x" '((2 . "gc200")) ))
   
8.    (if(setq ss(ssget '((2 . "gc200")) ))
   
9.     (progn
   
10.   (initget 1)
    
11.   (setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么就输入0>>>"))
    
12.   (initget 1)
    
13.   (setq len(fix(getreal "\n输入要保留的小数位数>>>")))
    
14.   (command "undo" "be")
    
15.   (setq  i 0)
    
16.   (while (< i (sslength ss))
    
17.     (vl-catch-all-apply
    
18.      '(lambda()
    
19.   (setq s(Ssname ss i))
    
20.   (setq snext(entnext s))
    
21.   (setq data(entget snext))
    
22. ;;;  (setq old (read(cdr(assoc 1 data))));调用属性值  改1位后不能再改两位
    
23.   (SETQ old(last(assoc 10(entget s))));调用块插入点z坐标 而非属性值
    
24.   (setq new (+ tt old))
    
25.   (setq data(subst(cons 1 (rtos new 2 len)) (assoc 1 data) data))
    
26.   (if(/= tt 0)
    
27.     (progn
    
28.   (setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))
    
29.   (setq data(subst(mapcar '+ (assoc 11 data) (list 0 0 0 tt)) (assoc 11 data) data))
    
30.         ))
    
31.   (entmod data);修改位数
    
32.   (if(/= tt 0)
    
33.     (progn
    
34.   (setq data(entget s '("*")))
    
35.   (setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))
    
36.   (entmod data)
    
37.       ));如果要修改值
    
38.   (entupd s);更新显示
    
39.        ));出错处理2：如果有些gcd层的块没有高程属性，那么跳过这个并继续下一个
    
40.   (setq i (1+ i))
    
41.     (princ "\r已完成 ")
    
42.     (princ (rtos (/ i (sslength ss) 0.01) 2 1))
    
43.     (princ " %.")
    
44.     (princ)
    
45.     ) ;while
    
46.   (command "undo" "e")
    
47.   ));if progn
    
48.     (alertt "没有找到GCD图层的块" 1 "CASS助手提示你" 48)
    
49.   )));if vl-catch  出错处理1：静默所有出错提示
    
50.   (princ)
    
51.   )

;2011年12月11日 02:31:31 BY yanshengjiang<br /> ;于贵州晴隆                              <br /> (defun c:gcd(/ tt ss i s snext data old new len);高程加常数<br />   (princ"\n南方cass高程点加常数 or 修改小数位数.建议先执行一次cass命令：根据注记修改高程。")<br />   (vl-catch-all-apply<br />     '(lambda()<br />   (if(setq s(ssget "x" '((2 . "gc200")) ))<br />    (if(setq ss(ssget '((2 . "gc200")) ))<br />     (progn<br />   (initget 1)<br />   (setq tt(getreal "\n输入要加的常数<负数表示减.如果只想改变位数那么就输入0>>>"))<br />   (initget 1)<br />   (setq len(fix(getreal "\n输入要保留的小数位数>>>")))<br />   (command "undo" "be")<br />   (setq  i 0)<br />   (while (< i (sslength ss))<br />     (vl-catch-all-apply<br />      '(lambda()<br />   (setq s(Ssname ss i))<br />   (setq snext(entnext s))<br />   (setq data(entget snext))<br /> ;;;  (setq old (read(cdr(assoc 1 data))));调用属性值  改1位后不能再改两位<br />   (SETQ old(last(assoc 10(entget s))));调用块插入点z坐标 而非属性值<br />   (setq new (+ tt old))<br />   (setq data(subst(cons 1 (rtos new 2 len)) (assoc 1 data) data))<br />   (if(/= tt 0)<br />     (progn<br />   (setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))<br />   (setq data(subst(mapcar '+ (assoc 11 data) (list 0 0 0 tt)) (assoc 11 data) data))<br />         ))<br />   (entmod data);修改位数<br />   (if(/= tt 0)<br />     (progn<br />   (setq data(entget s '("*")))<br />   (setq data(subst(mapcar '+ (assoc 10 data) (list 0 0 0 tt)) (assoc 10 data) data))<br />   (entmod data)<br />       ));如果要修改值<br />   (entupd s);更新显示<br />        ));出错处理2：如果有些gcd层的块没有高程属性，那么跳过这个并继续下一个<br />   (setq i (1+ i))<br />     (princ "\r已完成 ")<br />     (princ (rtos (/ i (sslength ss) 0.01) 2 1))<br />     (princ " %.")<br />     (princ)<br />     ) ;while<br />   (command "undo" "e")<br />   ));if progn<br />     (alertt "没有找到GCD图层的块" 1 "CASS助手提示你" 48)<br />   )));if vl-catch  出错处理1：静默所有出错提示<br />   (princ)<br />   )

你有种再说一遍

yanshengjiang 发表于 2024-7-18 11:21
测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。

自从我知道有一个叫十亿行天文台数据挑战,我就觉得超过2秒的功能,真的好慢

yanshengjiang

gzxl 发表于 2024-7-18 20:20
lisp 测试时间，不管是 autolisp，还是 vl
尽量代码简化，同等的条件下。
我知道本来 repeat nth 就耗费 ...

要while要好些哇  我试试

yanshengjiang

测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。

czb203

你有种再说一遍 发表于 2024-7-18 11:44
自从我知道有一个叫十亿行天文台数据挑战,我就觉得超过2秒的功能,真的好慢

大神的眼界果然不同

你有种再说一遍

czb203 发表于 2024-7-18 18:52
大神的眼界果然不同

不说你们不转来c#,嘿嘿

gzxl

lisp 测试时间，不管是 autolisp，还是 vl
尽量代码简化，同等的条件下。
我知道本来 repeat nth 就耗费时间，这很早就测试过了
不要加入 error command 等相关的代码

gble119

源码分享 必顶

VBALISPER

yanshengjiang 发表于 2024-7-18 11:21
测试两万个数据：AL写法用时8秒，新的VL写法用时10秒。

那不是白写了。

VBALISPER

坐标暴露了，MG的导弹已锁定，快逃。