[源码]勘丈地籍图绘图程序

004

1. ;;;勘丈地籍图绘图程序
   
2. ;;;wkq004  20140420
   
3. (setvar "cmdecho" 0)
   
4. 
   
5. (if (setq layerE (tblobjname "layer" "004YS"))
   
6.   (progn
   
7.     (setq layerEL (entget layerE))
   
8.     (setq ass62 (assoc 62 layerEL))
   
9.     (if  (/= 4 (cdr ass62))
   
10.       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
    
11.        (entmod layerEL)
    
12.       )
    
13.     )
    
14.   )
    
15.   (entmake (list '(0 . "LAYER")
    
16.      '(100 . "AcDbSymbolTableRecord")
    
17.      '(100 . "AcDbLayerTableRecord")
    
18.      '(70 . 0)
    
19.      '(6 . "Continuous")
    
20.      '(62 . 4)
    
21.      (cons 2 "004YS")
    
22.      )
    
23.   )
    
24. )
    
25. ;;;(if (setq layerE (tblobjname "layer" "004YS"))
    
26. ;;;  (progn
    
27. ;;;    (setq layerEL (entget layerE))
    
28. ;;;    (if  (eq nil (setq ass62 (assoc 62 layerEL)))
    
29. ;;;      (progn
    
30. ;;;  (setq el
    
31. ;;;         (cons
    
32. ;;;     (nth 0 layerEL)
    
33. ;;;     (cons (nth 1 layerEL)
    
34. ;;;           (cons (cons 62 4) (cddr layerEl))
    
35. ;;;     )
    
36. ;;;         )
    
37. ;;;  )
    
38. ;;;  (entmod el)
    
39. ;;;      )
    
40. ;;;      (if (/= 4 (cdr ass62))
    
41. ;;;  (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
    
42. ;;;         (entmod layerEL)
    
43. ;;;  )
    
44. ;;;      )
    
45. ;;;    )
    
46. ;;;  )
    
47. ;;;)
    
48. (if (setq layerE (tblobjname "layer" "004FJ"))
    
49.   (progn
    
50.     (setq layerEL (entget layerE))
    
51.     (setq ass62 (assoc 62 layerEL))
    
52.     (if  (/= 5 (cdr ass62))
    
53.       (progn (setq layerEL (subst (cons 62 5) ass62 layerEL))
    
54.        (entmod layerEL)
    
55.       )
    
56.     )
    
57.   )
    
58.   (entmake (list '(0 . "LAYER")
    
59.      '(100 . "AcDbSymbolTableRecord")
    
60.      '(100 . "AcDbLayerTableRecord")
    
61.      '(70 . 0)
    
62.      '(6 . "Continuous")
    
63.      '(62 . 5)
    
64.      (cons 2 "004FJ")
    
65.      )
    
66.   )
    
67. )
    
68. 
    
69. (if (setq layerE (tblobjname "layer" "004GFJ"))
    
70.   (progn
    
71.     (setq layerEL (entget layerE))
    
72.     (setq ass62 (assoc 62 layerEL))
    
73.     (if  (/= 2 (cdr ass62))
    
74.       (progn (setq layerEL (subst (cons 62 2) ass62 layerEL))
    
75.        (entmod layerEL)
    
76.       )
    
77.     )
    
78.   )
    
79. 
    
80.   (entmake (list '(0 . "LAYER")
    
81.      '(100 . "AcDbSymbolTableRecord")
    
82.      '(100 . "AcDbLayerTableRecord")
    
83.      '(70 . 0)
    
84.      '(6 . "Continuous")
    
85.      '(62 . 2)
    
86.      (cons 2 "004GFJ")
    
87.      )
    
88.   )
    
89. )
    
90. 
    
91. (if (setq layerE (tblobjname "layer" "004QSX"))
    
92.   (progn
    
93.     (setq layerEL (entget layerE))
    
94.     (setq ass62 (assoc 62 layerEL))
    
95.     (if  (/= 1 (cdr ass62))
    
96.       (progn (setq layerEL (subst (cons 62 1) ass62 layerEL))
    
97.        (entmod layerEL)
    
98.       )
    
99.     )
    
100.   )
     
101. 
     
102.   (entmake (list '(0 . "LAYER")
     
103.      '(100 . "AcDbSymbolTableRecord")
     
104.      '(100 . "AcDbLayerTableRecord")
     
105.      '(70 . 0)
     
106.      '(6 . "Continuous")
     
107.      '(62 . 1)
     
108.      (cons 2 "004QSX")
     
109.      )
     
110.   )
     
111. )
     
112. 
     
113. (if (setq layerE (tblobjname "layer" "004权利人"))
     
114.   (progn
     
115.     (setq layerEL (entget layerE))
     
116.     (setq ass62 (assoc 62 layerEL))
     
117.     (if  (/= 4 (cdr ass62))
     
118.       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
     
119.        (entmod layerEL)
     
120.       )
     
121.     )
     
122.   )
     
123.   (entmake (list '(0 . "LAYER")
     
124.      '(100 . "AcDbSymbolTableRecord")
     
125.      '(100 . "AcDbLayerTableRecord")
     
126.      '(70 . 0)
     
127.      '(6 . "Continuous")
     
128.      '(62 . 4)
     
129.      (cons 2 "004权利人")
     
130.      )
     
131.   )
     
132. )
     
133. 
     
134. (if (setq layerE (tblobjname "layer" "004序号"))
     
135.   (progn
     
136.     (setq layerEL (entget layerE))
     
137.     (setq ass62 (assoc 62 layerEL))
     
138.     (if  (/= 4 (cdr ass62))
     
139.       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
     
140.        (entmod layerEL)
     
141.       )
     
142.     )
     
143.   )
     
144.   (entmake (list '(0 . "LAYER")
     
145.      '(100 . "AcDbSymbolTableRecord")
     
146.      '(100 . "AcDbLayerTableRecord")
     
147.      '(70 . 0)
     
148.      '(6 . "Continuous")
     
149.      '(62 . 4)
     
150.      (cons 2 "004序号")
     
151.      )
     
152.   )
     
153. )
     
154. 
     
155. 
     
156. (defun c:QD ()
     
157.   (princ "\n权属线起点")
     
158.   (setq ss (cadr (ssgetfirst)))
     
159.   (if (and ss (= (setq ssn (sslength ss)) 1))
     
160.     (progn
     
161.       (setq e (ssname ss 0))
     
162.       (setq el (entget e))
     
163.       (setq pt (cdr (assoc 10 el)))
     
164.       (setq pt1 (polar pt (* 0.25 pi) 1))
     
165.       (setq pt2 (polar pt (* 1.25 pi) 1))
     
166.       (setq pt3 (polar pt (* 0.75 pi) 1))
     
167.       (setq pt4 (polar pt (* 1.75 pi) 1))
     
168.       (grdraw pt1 pt2 1)
     
169.       (grdraw pt3 pt4 1)
     
170.     )
     
171.     (progn
     
172.       (setq e (car (entsel "\n选择权属线")))
     
173.       (setq el (entget e))
     
174.       (setq pt (cdr (assoc 10 el)))
     
175.       (setq pt1 (polar pt (* 0.25 pi) 1))
     
176.       (setq pt2 (polar pt (* 1.25 pi) 1))
     
177.       (setq pt3 (polar pt (* 0.75 pi) 1))
     
178.       (setq pt4 (polar pt (* 1.75 pi) 1))
     
179.       (grdraw pt1 pt2 -1)
     
180.       (grdraw pt3 pt4 -1)
     
181.     )
     
182.   )
     
183.   (princ)
     
184. )
     
185. 
     
186. 
     
187. (defun c:0 (/ ss)
     
188.   (setq ss (cadr (ssgetfirst)))
     
189.   (if ss
     
190.     '()
     
191.     (progn
     
192.       (princ "\n选择要归到0层的对象：")
     
193.       (setq ss (ssget))
     
194.     )
     
195.   )
     
196.   (if ss
     
197.     (progn (command "change" ss "" "p" "la" "0" "")
     
198.      (princ "\n对象已归到0层：")
     
199.     )
     
200.   )
     
201.   (princ)
     
202. )
     
203. 
     
204. 
     
205. (defun c:sx ()
     
206.   (setvar "SORTENTS" 0)
     
207.   (if (setq ss (ssget "x" '((8 . "0"))))
     
208.     (command "draworder" ss "" "B")
     
209.   )
     
210.   (if (setq ss (ssget "x" '((8 . "JZD"))))
     
211.     (command "draworder" ss "" "B")
     
212.   )
     
213.   (if (setq ss (ssget "x" '((8 . "*影像*"))))
     
214.     (command "draworder" ss "" "B")
     
215.   )
     
216.   (princ)
     
217. )
     
218. 
     
219. (defun c:0s ()
     
220.   (if (setq ss (ssget "x" '((8 . "0"))))
     
221.     (command "draworder" ss "" "F")
     
222.   )
     
223. )
     
224. 
     
225. (defun c:QSS ()
     
226.   (setvar "SORTENTS" 0)
     
227.   (if (setq ss (ssget "x" '((8 . "QSX"))))
     
228.     (command "draworder" ss "" "F")
     
229.   )
     
230.   (princ)
     
231. )
     
232. 
     
233. (defun c:QSX ()
     
234.   (setvar "SORTENTS" 0)
     
235.   (if (setq ss (ssget "x" '((8 . "QSX"))))
     
236.     (command "draworder" ss "" "B")
     
237.   )
     
238.   (if (setq ss (ssget "x" '((8 . "*影像*"))))
     
239.     (command "draworder" ss "" "B")
     
240.   )
     
241.   (princ)
     
242. )
     
243. 
     
244. (defun c:YS (/ ss)
     
245.   (princ "\n檐水：")
     
246.   (setq ss (cadr (ssgetfirst)))
     
247.   (if (and ss (< (setq ssn (sslength ss)) 3))
     
248.     (progn
     
249.       (command "PUTP" "c" "143132" ss "")
     
250.     )
     
251.     (progn
     
252.       (command "DD" "143132")
     
253.     )
     
254.   )
     
255.   (princ)
     
256. )
     
257. 
     
258. (defun c:FJ (/ ss)
     
259.   (princ "\n房基：")
     
260.   (setq ss (cadr (ssgetfirst)))
     
261.   (if (and ss (< (setq ssn (sslength ss)) 3))
     
262.     (progn
     
263.       (command "PUTP" "c" "143133" ss "")
     
264.     )
     
265.     (progn
     
266.       (command "DD" "143133")
     
267.     )
     
268.   )
     
269.   (princ)
     
270. )
     
271. 
     
272. (defun c:QS (/ ss)
     
273.   (princ "\n权属线：")
     
274.   (setq ss (cadr (ssgetfirst)))
     
275.   (if (and ss (= (setq ssn (sslength ss)) 1))
     
276.     (progn
     
277.       (command "PUTP" "c" "143134" ss "")
     
278.     )
     
279.     (progn
     
280.       (command "DD" "143134")
     
281.     )
     
282.   )
     
283.   (princ)
     
284. )
     
285. 
     
286. 
     
287. (defun c:DK (/ ss)
     
288.   (princ "\n加固坎：")
     
289.   (setq ss (cadr (ssgetfirst)))
     
290.   (if (and ss (< (setq ssn (sslength ss)) 3))
     
291.     (progn
     
292.       (command "PUTP" "c" "143135" ss "")
     
293.     )
     
294.     (progn
     
295.       (command "DD" "143135")
     
296.     )
     
297.   )
     
298.   (princ)
     
299. )
     
300. 
     
301. (defun c:YZ (/ ss)
     
302.   (princ "\n雨罩：")
     
303.   (setq ss (cadr (ssgetfirst)))
     
304.   (if (and ss (< (setq ssn (sslength ss)) 3))
     
305.     (progn
     
306.       (command "PUTP" "c" "143130" ss "")
     
307.     )
     
308.     (command "DD" "143130")
     
309.   )
     
310.   (princ)
     
311. )

;;;勘丈地籍图绘图程序<br /> ;;;wkq004  20140420<br /> (setvar "cmdecho" 0)<br /> <br /> (if (setq layerE (tblobjname "layer" "004YS"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 4 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 4)<br />      (cons 2 "004YS")<br />      )<br />   )<br /> )<br /> ;;;(if (setq layerE (tblobjname "layer" "004YS"))<br /> ;;;  (progn<br /> ;;;    (setq layerEL (entget layerE))<br /> ;;;    (if  (eq nil (setq ass62 (assoc 62 layerEL)))<br /> ;;;      (progn<br /> ;;;  (setq el<br /> ;;;         (cons<br /> ;;;     (nth 0 layerEL)<br /> ;;;     (cons (nth 1 layerEL)<br /> ;;;           (cons (cons 62 4) (cddr layerEl))<br /> ;;;     )<br /> ;;;         )<br /> ;;;  )<br /> ;;;  (entmod el)<br /> ;;;      )<br /> ;;;      (if (/= 4 (cdr ass62))<br /> ;;;  (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))<br /> ;;;         (entmod layerEL)<br /> ;;;  )<br /> ;;;      )<br /> ;;;    )<br /> ;;;  )<br /> ;;;)<br /> (if (setq layerE (tblobjname "layer" "004FJ"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 5 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 5) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 5)<br />      (cons 2 "004FJ")<br />      )<br />   )<br /> )<br /> <br /> (if (setq layerE (tblobjname "layer" "004GFJ"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 2 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 2) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br /> <br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 2)<br />      (cons 2 "004GFJ")<br />      )<br />   )<br /> )<br /> <br /> (if (setq layerE (tblobjname "layer" "004QSX"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 1 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 1) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br /> <br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 1)<br />      (cons 2 "004QSX")<br />      )<br />   )<br /> )<br /> <br /> (if (setq layerE (tblobjname "layer" "004权利人"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 4 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 4)<br />      (cons 2 "004权利人")<br />      )<br />   )<br /> )<br /> <br /> (if (setq layerE (tblobjname "layer" "004序号"))<br />   (progn<br />     (setq layerEL (entget layerE))<br />     (setq ass62 (assoc 62 layerEL))<br />     (if  (/= 4 (cdr ass62))<br />       (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))<br />        (entmod layerEL)<br />       )<br />     )<br />   )<br />   (entmake (list '(0 . "LAYER")<br />      '(100 . "AcDbSymbolTableRecord")<br />      '(100 . "AcDbLayerTableRecord")<br />      '(70 . 0)<br />      '(6 . "Continuous")<br />      '(62 . 4)<br />      (cons 2 "004序号")<br />      )<br />   )<br /> )<br /> <br /> <br /> (defun c:QD ()<br />   (princ "\n权属线起点")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (= (setq ssn (sslength ss)) 1))<br />     (progn<br />       (setq e (ssname ss 0))<br />       (setq el (entget e))<br />       (setq pt (cdr (assoc 10 el)))<br />       (setq pt1 (polar pt (* 0.25 pi) 1))<br />       (setq pt2 (polar pt (* 1.25 pi) 1))<br />       (setq pt3 (polar pt (* 0.75 pi) 1))<br />       (setq pt4 (polar pt (* 1.75 pi) 1))<br />       (grdraw pt1 pt2 1)<br />       (grdraw pt3 pt4 1)<br />     )<br />     (progn<br />       (setq e (car (entsel "\n选择权属线")))<br />       (setq el (entget e))<br />       (setq pt (cdr (assoc 10 el)))<br />       (setq pt1 (polar pt (* 0.25 pi) 1))<br />       (setq pt2 (polar pt (* 1.25 pi) 1))<br />       (setq pt3 (polar pt (* 0.75 pi) 1))<br />       (setq pt4 (polar pt (* 1.75 pi) 1))<br />       (grdraw pt1 pt2 -1)<br />       (grdraw pt3 pt4 -1)<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> <br /> (defun c:0 (/ ss)<br />   (setq ss (cadr (ssgetfirst)))<br />   (if ss<br />     '()<br />     (progn<br />       (princ "\n选择要归到0层的对象：")<br />       (setq ss (ssget))<br />     )<br />   )<br />   (if ss<br />     (progn (command "change" ss "" "p" "la" "0" "")<br />      (princ "\n对象已归到0层：")<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> <br /> (defun c:sx ()<br />   (setvar "SORTENTS" 0)<br />   (if (setq ss (ssget "x" '((8 . "0"))))<br />     (command "draworder" ss "" "B")<br />   )<br />   (if (setq ss (ssget "x" '((8 . "JZD"))))<br />     (command "draworder" ss "" "B")<br />   )<br />   (if (setq ss (ssget "x" '((8 . "*影像*"))))<br />     (command "draworder" ss "" "B")<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:0s ()<br />   (if (setq ss (ssget "x" '((8 . "0"))))<br />     (command "draworder" ss "" "F")<br />   )<br /> )<br /> <br /> (defun c:QSS ()<br />   (setvar "SORTENTS" 0)<br />   (if (setq ss (ssget "x" '((8 . "QSX"))))<br />     (command "draworder" ss "" "F")<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:QSX ()<br />   (setvar "SORTENTS" 0)<br />   (if (setq ss (ssget "x" '((8 . "QSX"))))<br />     (command "draworder" ss "" "B")<br />   )<br />   (if (setq ss (ssget "x" '((8 . "*影像*"))))<br />     (command "draworder" ss "" "B")<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:YS (/ ss)<br />   (princ "\n檐水：")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (< (setq ssn (sslength ss)) 3))<br />     (progn<br />       (command "PUTP" "c" "143132" ss "")<br />     )<br />     (progn<br />       (command "DD" "143132")<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:FJ (/ ss)<br />   (princ "\n房基：")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (< (setq ssn (sslength ss)) 3))<br />     (progn<br />       (command "PUTP" "c" "143133" ss "")<br />     )<br />     (progn<br />       (command "DD" "143133")<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:QS (/ ss)<br />   (princ "\n权属线：")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (= (setq ssn (sslength ss)) 1))<br />     (progn<br />       (command "PUTP" "c" "143134" ss "")<br />     )<br />     (progn<br />       (command "DD" "143134")<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> <br /> (defun c:DK (/ ss)<br />   (princ "\n加固坎：")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (< (setq ssn (sslength ss)) 3))<br />     (progn<br />       (command "PUTP" "c" "143135" ss "")<br />     )<br />     (progn<br />       (command "DD" "143135")<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> (defun c:YZ (/ ss)<br />   (princ "\n雨罩：")<br />   (setq ss (cadr (ssgetfirst)))<br />   (if (and ss (< (setq ssn (sslength ss)) 3))<br />     (progn<br />       (command "PUTP" "c" "143130" ss "")<br />     )<br />     (command "DD" "143130")<br />   )<br />   (princ)<br /> )

f4800

[源码]勘丈地籍图绘图程序

wm123456

感谢分享好东西

xuhaiguang

感谢分享好东西

gzxl

一早上明经见到有测绘的好源码，顶顶顶

杜阳

专业测绘人人员 终于有大作了  支持    强烈支持

树櫴希德

大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

wkq004

树櫴希德 发表于 2014-5-12 14:34
大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

gzxl有这方面的源码，看他发过的主题

wkq004

树櫴希德 发表于 2014-5-12 14:34
大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

高程点内插程序(已更新)

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100043&extra=&mobile=yes

jxy308

是个好东西得支持

ynpxqjlb

感谢分享！！！！