论坛
商城
新人指南
地信网论坛
»
论坛
›
『测绘工程』
›
工程测量
›
土地勘测定界用的小程序
免费视频
|
新人指南
|
投诉删帖
|
广告合作
|
地信网APP下载
1
2
3
/ 3 页
下一页
返回列表
查看:
7778
|
回复:
25
[勘测定界]
土地勘测定界用的小程序
[复制链接]
永颉同心
永颉同心
当前离线
积分
41082
雷达卡
2945
主题
12万
铜板
537
好友
版主
有困难,找信娘!
积分
41082
发消息
发表于 2012-1-20 19:11
|
显示全部楼层
|
阅读模式
土地勘测定界实用的小程序.rar
(12.06 KB, 下载次数: 793)
2012-1-20 19:11 上传
点击文件名下载附件
程序
评分
参与人数
1
铜板
+1
收起
理由
胜境萌源
+ 1
查看全部评分
相关帖子
•
计算异常下限的小程序
•
谁有北京龙软3.0绘图程序破解版(或有注册码)
•
物探辅助程序
•
求助 occam一维反演程序
•
关于统改路线号和地质点号后,编辑PRB导致程序崩溃的问题
•
arcgislicensemanager服务器启动不了
•
安卓版 数字地质填图 交流
•
实用的LIAP程序
•
CASS下批量打印程序
•
求等角圆锥坐标反解程序,有重谢!
有困难,找信娘!
http://bbs.3s001.com
回复
使用道具
举报
提升卡
沉默卡
喧嚣卡
变色卡
抢沙发
显身卡
zxuan2119
zxuan2119
当前离线
积分
122
雷达卡
1
主题
729
铜板
0
好友
助理工程师
助理工程师, 积分 122, 距离下一级还需 278 积分
助理工程师, 积分 122, 距离下一级还需 278 积分
积分
122
发消息
发表于 2020-6-24 15:52
|
显示全部楼层
反编译lisp如下:
(defun C:nn()
(command "layer" "m" "边界线" "c" "4" "" "")
(command "-boundary" pause "")
)
(defun C:QQ( / xk point ltlfx ltlfx1 li s)
(setq blc (getvar "LTSCALE"))
(command "osnap" "nea,endp,mid")
(setq xk(getreal "\n输入线宽:<0.3>"))
(if (= xk nil) (setq xk (* blc 0.3)))
(lqpl1 xk)
)
(defun lqpl1(kuan)
(command "osnap" "end,nea,per")
(setq point(getpoint "\n输入点:"))
(setq ltlfx(list (-(car point) 1) (+(cadr point) 1)))
(setq ltlfx1(list (+(car point) 1) (-(cadr point) 1)))
(command "pline" point "w" kuan kuan)
(while (/= point nil)
(setq point(getpoint point "\n输入点"))
(command point)
)
(command)
(setq li (entlast))
(command "pedit" li "L" "on" "x")
(initget "Yes No")
(setq s (getkword "\n拟合吗?<N>"))
(if (= s "Yes") (command "pedit" li "f" "x"))
(command "pline" ltlfx "w" "0" "" "")
)
(defun C:ee( / xk point)
(setq blc(getvar "LTSCALE"))
(setq xk(getreal "\n输入半径:<0.5>"))
(if (= xk nil) (setq xk 0.5))
(setq point(getpoint "\n输入点"))
(while (/= point nil)
(command "circle" point (* blc xk) "")
(setq point(getpoint "\n输入点"))
)
)
(defun C:dx( / i n d pt1 xk)
(setq blc 5)
(setq xk(getreal "\n输入半径:<0.2>"))
(if (= xk nil) (setq xk 0.2))
(db)
(command "layer" "m" "界址点圆" "c" "7" "" "")
(setq i 0 n (length d))
(while (< i n)
(setq pt1 (nth i d))
(command "circle" pt1 ( * blc xk) "")
(setq i (1+ i))
)
)
(defun C:dx1( / i n d pt1 xk)
(setq blc 5)
(setq xk(getreal "\n输入半径:<1>"))
(if (= xk nil) (setq xk 1))
(db)
(command "layer" "m" "电路圆圈" "c" "1" "" "")
(setq i 0 n (length d))
(while (< i n)
(setq pt1 (nth i d))
(command "circle" pt1 ( * blc xk) "")
(setq i (1+ i))
)
)
(defun C:xH( / i n d pt1 xk)
(setq blc(getvar "LTSCALE"))
(setq xh(getreal "\n输入起始序号:<1>"))
(if (= xh nil) (setq xh 1))
(db)
(setq i 0 n (length d))
(while (< i n)
(setq pt1 (nth i d))
(command "text" "j" "m" pt1 (* 1.2 blc) 0 (fix (+ xh i)))
(setq i (1+ i))
)
)
(defun db(/ kg ename sut lb b pt cm bh pt1 i f1 f2)
(setq kg 0)
(if (= kg 0)(setq ename (car (entsel "\n选择实体 : "))))
(if ename (progn
(setq d nil lb (entget ename) bh (cdr (assoc 70 lb)))
(setq b (cdr (assoc 0 lb)) cm (cdr (assoc 8 lb)))
(command "layer" "s" cm "")
(if (= b "POLYLINE")
(progn
(setq sut (entnext ename))
(while (/= (cdr (assoc 0 (entget sut))) "SEQEND")
(setq pt (cdr (assoc 10 (entget sut))))
(setq d (cons pt d))
(setq sut (entnext sut))
)
(if (= bh 1) (setq d (cons (last d) d)))
))
(if (= b "LINE")
(setq d (cons (cdr (assoc 10 lb)) d) d (cons (cdr (assoc 11 lb)) d)))
(if (= b "CIRCLE")(progn
(setq pt (cdr (assoc 10 lb))
r (cdr (assoc 40 lb)))
(setq i 0)
(while (<= i 360)
(setq pt1 (polar pt (/ i 57.0) r))
(setq d (cons pt1 d))
(setq i (+ i 5))
)
))
(if (= b "LWPOLYLINE")(progn
(setq nn (length lb) kk 1)
(while (< kk nn)
(if (= 10 (car (nth kk lb)))(progn
(setq x (nth 1 (nth kk lb))
y (nth 2 (nth kk lb))
)
(setq d (cons (list x y) d))
))
(setq kk (1+ kk))
)
(if (= bh 1) (setq d (cons (last d) d)))
))
(if (= b "ARC")(progn
(setq pt (cdr (assoc 10 lb))
r (cdr (assoc 40 lb))
f1 (cdr (assoc 50 lb))
f2 (cdr (assoc 51 lb)))
(setq i f1)
(if (< f2 f1) (setq f2 (+ f2 (* 2 pi))))
(while (<= i f2)
(setq pt1 (polar pt i r))
(setq d (cons pt1 d))
(setq i (+ i 0.1))
)
(setq d (cons (polar pt f2 r) d))
))
))
(if d (setq d (reverse d)))
)
(defun C:jzd( / blc dhxy i n pt dh pt0 pt1 pt2 pt3 l )
(setq blc 5)
(setq dhxy nil)
(db)
(setq i 0 n (length d))
(setq pt (nth i d) dh 1)
(while pt
(setq dhxy (cons (list dh pt) dhxy))
(setq dh ( + 1 dh) i ( + 1 i))
(setq pt (nth i d))
)
(command "osnap" "off" )
(setq dhxy (reverse dhxy))
(if dhxy (progn
(setq pt (getpoint "\n指定界址点表的左上角:"))
(command "layer" "m" "界址点号" "c" "3" "" "")
(setq plq (polar pt 4.712 (* 6 blc)))
(setq plq00 (polar pt 4.712 (* 2 blc)))
(command "line" (polar pt 0 (* 60 blc)) (polar pt 0 (* 80 blc)) "")
(command "line" (polar plq 0 (* 80 blc)) (polar pt 0 (* 80 blc)) "")
(setq n (length dhxy))
(setq i 0 pt0 pt plq0 plq)
(while (< i (+ n 3))
(setq pt1 (polar pt 0 (* 60 blc)))
(command "line" pt pt1 "")
(setq pt (polar pt 4.712 (* 4 blc)))
(setq i (1+ i))
)
(setq i 0)
(while (< i (+ n 1))
(setq plq1 (polar plq 0 (* 60 blc)))
(setq plq2 (polar plq 0 (* 80 blc)))
(command "line" plq1 plq2 "")
(setq plq (polar plq 4.712 (* 4 blc)))
(setq i (1+ i))
)
(setq pt1 (polar pt0 0 (* 10 blc)))
(setq pt2 (polar pt0 0 (* 35 blc)))
(setq pt3 (polar pt0 0 (* 60 blc)))
(setq plq4 (polar plq0 0 (* 80 blc)))
(setq x (car pt0) y (cadr pt0))
(setq aa (car plq00) bb (cadr plq00))
(setq l 0)
(while (<= l (1+ n))
(command "line" pt1 (polar pt1 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt1 (polar pt1 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l (1+ n))
(command "line" pt2 (polar pt2 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt2 (polar pt2 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l (1+ n))
(command "line" pt3 (polar pt3 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt3 (polar pt3 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l (1+ n))
(command "line" pt0 (polar pt0 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt0 (polar pt0 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l (1- n))
(command "line" plq4 (polar plq4 4.712 (* (+ 0 1) 4 blc)) "")
(setq plq4 (polar plq4 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
)
(command "text" "j" "m" (list (+ x (* 5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "点号")
(command "text" "j" "m" (list (+ x (* 22.5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "X坐标")
(command "text" "j" "m" (list (+ x (* 47.5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "Y坐标")
(command "text" "j" "m" (list (+ x (* 70.5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "边长")
(setq i 0)
(setq xh (getreal "\n输入起始序号:"))
(if (= xh nil) (setq xh 1))
(setq xh (- xh 1))
(while (< i n)
(setq ppoinx (caadr (nth i dhxy)))
(setq ppoiny (cadadr (nth i dhxy)))
(setq ppoin (list ( + ppoinx 9) ppoiny))
(command "text" "j" "m" ppoin (* 1.5 blc) 0 (fix (+ xh (car (nth i dhxy)))))
(setq pt1 (list (+ x (* 5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(setq pt2 (list (+ x (* 22.5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(setq pt3 (list (+ x (* 47.5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(command "text" "j" "m" pt1 (* 2.5 blc) 0 (fix( + (car (nth i dhxy))xh)))
(command "text" "j" "m" pt2 (* 2.5 blc) 0 (rtos (cadr (cadr (nth i dhxy))) 2 3))
(command "text" "j" "m" pt3 (* 2.5 blc) 0 (rtos (car (cadr (nth i dhxy))) 2 3))
(setq i (1+ i))
)
(setq pt1 (list (+ x (* 5 blc)) (- y (* 2 blc) (* blc 4 (1+ n)))))
(setq pt2 (list (+ x (* 22.5 blc)) (- y (* 2 blc) (* blc 4 (1+ n)))))
(setq pt3 (list (+ x (* 47.5 blc)) (- y (* 2 blc) (* blc 4 (1+ n)))))
(command "text" "j" "m" pt1 (* 2.5 blc) 0 (fix( + (car (nth 0 dhxy))xh)))
(command "text" "j" "m" pt2 (* 2.5 blc) 0 (rtos (cadr (cadr (nth 0 dhxy))) 2 3))
(command "text" "j" "m" pt3 (* 2.5 blc) 0 (rtos (car (cadr (nth 0 dhxy))) 2 3))
(command "text" "j" "m" (list (+ x (* 30 blc)) (+ y (* 4 blc))) (* 2.5 blc) 0 "界址点坐标表")
(setq i 0)
(while (< i (1- n))
(setq ppoin1 (cadr (nth i dhxy)))
(setq ppoin2 (cadr (nth (+ i 1) dhxy)))
(command "dist" ppoin1 ppoin2)
(setq pt4 (list (+ aa (* 70.5 blc)) (- bb (* 2 blc) (* blc 4 (1+ i)))))
(setq distt(getvar "DISTANCE"))
(command "text" "j" "m" pt4 (* 2.5 blc) 0 (rtos distt 2 3))
(setq i (1+ i))
)
(setq ppoin1 (cadr (nth (1- n) dhxy)))
(setq ppoin2 (cadr (nth 0 dhxy)))
(command "dist" ppoin1 ppoin2)
(setq pt4 (list (+ aa (* 70.5 blc)) (- bb (* 2 blc) (* blc 4 n))))
(setq distt(getvar "DISTANCE"))
(command "text" "j" "m" pt4 (* 2.5 blc) 0 (rtos distt 2 3))
))
)
(defun C:aa()
(command "layer" "s" "zj" "")
(command "dtext" pause)
)
(defun C:cc( / a w )
(setq a (getreal "\n<1,2,3>:"))
(cond
((= a 1) (setq w "ka0.dwg"))
((= a 2) (setq w "ka0.b"))
((= a 3) (setq w "ka0.b竖"))
((= a 4) (setq w "ka0编制"))
((= a 5) (setq w "ka0竖向"))
((= a 6) (setq w "ka1"))
((= a 7) (setq w "ka1.b"))
((= a 8) (setq w "ka1编制"))
((= a 9) (setq w "ka1测量宽 "))
((= a 10) (setq w "ka1测量竖"))
((= a 11) (setq w "ka1测量"))
((= a 12) (setq w "ka1加长"))
((= a 13) (setq w "ka1加宽"))
((= a 14) (setq w "ka1特"))
((= a 15) (setq w "ka2"))
((= a 16) (setq w "ka2.b"))
((= a 17) (setq w "ka2接图"))
((= a 18) (setq w "ka2竖向"))
((= a 19) (setq w "ka3"))
((= a 20) (setq w "ka3.b"))
((= a 21) (setq w "ka4"))
((= a 22) (setq w "ka2接竖"))
((= a 23) (setq w "ka5"))
((= a 24) (setq w "ka6"))
((= a 25) (setq w "kao"))
)
(command "layer" "s" "0" "")
(command "insert" W PAUSE (getvar "LTSCALE") "" "" "")
)
(defun C:zbb( / pt pt1 pt2 pt3 pt0 x y dhxy i dh)
(setq blc(getvar "LTSCALE"))
(setq dhxy nil)
(command "layer" "m" "jzd" "")
(command "osnap" "cen,end")
(setq pt (getpoint "\n捕捉界址点:"))
(while pt
(command "osnap" "off")
(setq dh (getstring "\n界址点号:"))
(setq pt1 (list (+ (car pt) (* 2.5 blc)) (+ (* 2.5 blc ) (cadr pt))))
(command "text" "m" pt1 (* 2.0 blc) 0 (strcase dh))
(setq dhxy (cons (list (strcase dh) pt) dhxy))
(command "osnap" "cen")
(setq pt (getpoint "\n捕捉界址点:"))
)
(command "osnap" "off")
(setq dhxy (reverse dhxy))
(if dhxy (progn
(setq pt (getpoint "\n指定界址点表的左上角:"))
(setq n (length dhxy))
(setq i 0 pt0 pt)
(while (< i (+ n 2))
(setq pt1 (polar pt 0 (* 60 blc)))
(command "line" pt pt1 "")
(setq pt (polar pt 4.712 (* 4 blc)))
(setq i (1+ i))
)
(setq pt1 (polar pt0 0 (* 10 blc)))
(setq pt2 (polar pt0 0 (* 35 blc)))
(setq pt3 (polar pt0 0 (* 60 blc)))
(setq x (car pt0) y (cadr pt0))
(setq l 0)
(while (<= l n)
(command "line" pt1 (polar pt1 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt1 (polar pt1 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l n)
(command "line" pt2 (polar pt2 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt2 (polar pt2 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l n)
(command "line" pt3 (polar pt3 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt3 (polar pt3 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
) (setq l 0)
(while (<= l n)
(command "line" pt0 (polar pt0 4.712 (* (+ 0 1) 4 blc)) "")
(setq pt0 (polar pt0 4.712 (* (+ 0 1) 4 blc)))
(setq l (+ 1 l))
)
(command "text" "j" "m" (list (+ x (* 5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "点号")
(command "text" "j" "m" (list (+ x (* 22.5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "X坐标")
(command "text" "j" "m" (list (+ x (* 47.5 blc)) (- y (* 2 blc))) (* 2.5 blc) 0 "Y坐标")
(setq i 0)
(while (< i n)
(setq pt1 (list (+ x (* 5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(setq pt2 (list (+ x (* 22.5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(setq pt3 (list (+ x (* 47.5 blc)) (- y (* 2 blc) (* blc 4 (1+ i)))))
(command "text" "j" "m" pt1 (* 2.5 blc) 0 (car (nth i dhxy)))
(command "text" "j" "m" pt2 (* 2.5 blc) 0 (rtos (cadr (cadr (nth i dhxy))) 2 3))
(command "text" "j" "m" pt3 (* 2.5 blc) 0 (rtos (car (cadr (nth i dhxy))) 2 3))
(setq i (1+ i))
)
(command "text" "j" "m" (list (+ x (* 30 blc)) (+ y (* 4 blc))) (* 3.0 blc) 0 "界址点坐标表")
))
(princ)
)
(defun C:jj()
(command "pedit" pause "e" "i")
)
(defun flz(reco / i0 ii zc le char)
(setq char nil)
(if (/= reco "")(progn
(setq i0 1 ii 1 zc (substr reco 1 1))
(while (/= zc "")
(while (= zc ",")
(setq i0 (1+ i0))
(setq zc (substr reco i0 1))
)
(if (/= zc "")(progn
(setq ii i0)
(while (and (/= zc ",") (/= zc ""))
(setq ii (1+ ii))
(setq zc (substr reco ii 1))
)
(setq le (- ii i0))
(setq str (substr reco i0 le))
(if (= str ".") (setq str ""))
(setq char (cons str char))
(setq i0 ii)
))
)
))
(if char (reverse char))
)
;展点
(defun C:sb( / fp pf sxb reco dh pt n s ii)
(command "layer" "m" "碎步点" "c" "6" "" "")
(setq pf (getfiled "指定坐标数据文件" "D:\gps文件" "dat" 2) blc 1)
(if pf (progn
(setq fp (open pf "r"))
(setq reco (read-line fp) ii 1)
(setq reco (read-line fp) ii 1)
(while reco
(setq sxb (flz reco) n (length sxb))
(setq dh (nth 0 sxb) pt (list (atof (nth 1 sxb)) (atof (nth 2 sxb)) (atof (nth 3 sxb))))
(command "point" pt)
(command "text" (polar pt (/ (* 7.5 pi) 4) (* blc 6)) (* 4 blc) 0 dh)
(setq reco (read-line fp) ii (1+ ii))
)
(close fp)
))
(princ "请等待...")
(command "zoom" "e")
(PRINC)
)
(defun C:rtk( / fp pf sxb reco dh pt n s ii)
(command "layer" "m" "zdf" "c" "3" "" "")
(setq pf (getfiled "指定坐标数据文件" "C:/" "" 2) blc 1)
(if pf (progn
(setq fp (open pf "r"))
(setq reco (read-line fp) ii 1)
;(setq reco (read-line fp) ii 1)
(while reco
(setq sxb (flz reco) n (length sxb))
(setq dh (fix(atof (nth 0 sxb))) pt (list (atof (nth 2 sxb)) (atof (nth 1 sxb))))
(command "point" pt)
(command "text" (polar pt (/ (* 7.25 pi) 4) (* blc 20)) (* 20 blc) 0 dh)
(setq reco (read-line fp) ii (1+ ii))
)
(close fp)
))
(COMMAND "ZOOM" "E" "")
(princ "请等待...")
(PRINC)
)
(defun C:as()
(setq ll(entsel))
(command "pedit" ll "l" "on" "" "")
)
(defun C:zdk()
(command "insert" "zdk" PAUSE "" "" "" "")
)
(defun C:xztc()
(command "layer" "m" "路" "c" "3" "" "")
(command "layer" "m" "屯" "c" "4" "" "")
(command "layer" "m" "林" "c" "2" "" "")
(command "layer" "m" "界线" "c" "6" "" "")
(command "layer" "m" "图廓" "c" "7" "" "")
(command "layer" "m" "地类" "c" "1" "" "")
(command "layer" "m" "注记" "c" "7" "" "")
)