征集CASS小程序

heart

广范征求CASS下VB、辅助小程序
方便大家在地形图绘制、数据处理、地籍、工程测量应用等小程序工具(VB LISP等)
发贴格式
程序名：
如何加载：
实现功能：

凡提供者小程序者，给予2威望和20铜版的奖励
特别优秀的程序给予10威望 40铜板奖励
根据大家的应用情况还可以追加奖励
欢迎大家参与

声明：
为方便大家交流，下载，不要回复与程序无关的话题，感谢你的合作，可评分发言，何何。

未来的迷茫

发一个可以自动处理地形图后期处理的压盖问题、植被和高程点注记。自动处理压盖

rark123

楼主，建议发程序的。附加程序出处和程序作者。尊重下写程序的人。谢谢。本帖发的程序有几个是本人写的。请尊重程序的开发者。

heart

程序名称： GCZJ.LSP 加载说明： 在CASSCAD下命令行输入命令APPLOAD，后单击先择此文件名，再单击“加载（L）”，对话框下方显示已成功加载后单击“关闭（C）”。然后在命令行输入命令"GC"按提示进行即可。 功能: 等高线间内插高程点。在野外如实测高程点较少时,此小程序对内业注高程点来说很有用。但注完后要重新展点，否则注出的高程点比原高程点字号大一些4、此小程序为原代码，有高手改进后请给我发一个:871531468

来源于
BEIDULZYZH
CASS小程序
http://bbs.3s001.com/thread-48140-1-1.html

953060982

看看这个东西可以有

miaoruibo232702

发一个纯数字生成高程点数据(命令tqsz)

moboli54

CASS里面 能用的CAD 命令。
把这个文件解压放到CASS安装文件SYSTEM里面覆盖原文件就可以了。。

hychyysx

批量改高程值的CAD命令.rar (1.24 KB, 下载次数: 565)

2011-4-21 08:13 上传

点击文件名下载附件
批量改高程值的CAD命令.

hychyysx

等高线修改.rar (83.89 KB, 下载次数: 797)

2011-4-21 08:11 上传

点击文件名下载附件
等高线修改

another

      根据图上的数字注记来重新生成高程点。。。。（运行的时候，请把其它的层关闭，仅留下数字注记所在层与GCD层）
  命令：ZGCD
   

zhb236623

;;图层操作函数．．．这个程序来自网上．．．．．．

1. (DEFUN C:qb()　;;显示全部图层
   
2.         (command "layer" "on" "*" "")
   
3.         (COMMAND "LAYER" "THAW" "*" "")
   
4.         (COMMAND "LAYER" "U" "*" "")
   
5.     (PRINC)
   
6. )
   
7. 
   
8. ;;;-----关闭所选对象所在图层(复选)--------
   
9. (DEFUN  C:dqg ()
   
10.   (setvar "cmdecho" 0)
    
11.   (prompt"\nSelect entities to turn off:")
    
12.   (setq ss (ssget))
    
13.   (if (and ss (sslength ss) 0)
    
14.     (progn
    
15.      (setq ct 0 len (sslength ss) cl (getvar "clayer"))
    
16.      (command ".layer")
    
17.      (while (< ct len)
    
18.          (setq la (cdr (assoc 8 (entget (ssname ss ct)))))
    
19.          (if (/= cl la)(command "off" la)
    
20.                        (progn (prompt "\nThe layer")
    
21.                               (prompt la)
    
22.                               (prompt "is CURRENT!")
    
23.                        )  ;end of progn
    
24.          )                ;end of if
    
25.          (if (= old nil)(setq OLD la)(setq OLD (strcat OLD "," la)))
    
26.          (setq ct (1+ ct))
    
27.        )                  ;end of while
    
28.        (command"")
    
29.      )                  ;end of progn
    
30. )                      ;end of if
    
31. (princ)
    
32. (setvar "cmdecho" 0) (prin1)
    
33. )
    
34. 
    
35. ;;;------------------------关闭除所选对象所在图层外的所有层-------------------------------
    
36. (defun C:dq(/ ES EN EL A)
    
37. (Princ "Selected Entity(s) Layers ISOLate.")
    
38. (setq ES(ssget) A 0 EN "" EL nil FL nil)
    
39. (while (/= EN nil)
    
40. (setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
    
41. (setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
    
42. (repeat (- A 2)
    
43. (setq EN (cdr (assoc ' 8 (entget (car EL))))
    
44.   FL (strcat EN "," FL) EL (cdr EL)) )
    
45. (command "LAYER" "OFF" "*" "Y" "ON" (eval FL) "")
    
46. (princ))
    
47. 
    
48. 
    
49. ;;;----------------------------锁定所选对象所在图层---------------------------------
    
50. (defun C:dqs(/ ES EN EL A)
    
51. (Princ "Selected Entity(s) Layers Locked.")
    
52. (setq ES(ssget) A 0 EN "" EL nil FL nil)
    
53. (while (/= EN nil)
    
54. (setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
    
55. (setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
    
56. (repeat (- A 2)
    
57. (setq EN (cdr (assoc ' 8 (entget (car EL))))
    
58.   FL (strcat EN "," FL) EL (cdr EL)) )
    
59. (command "LAYER" "LO" (eval FL) "")
    
60. (princ))

复制代码

b176877840

cass小工具
功能不详
来源于网络

cjs793

回复 hychyysx 的帖子

这个有哪些功能啊

南飞雁

很好用的小工具  

heart

lisp程序

xiaoxuesheng

        发一个等高线间内插高程点的程序 。在野外如实测高程点较少时,此小程序对内业注高程点来说很有用，appload加载 等高线之间内插高程点nc.lsp 命令名:nc