求dwg/dxf转shp的程序或LISP

zhangzl

求dwg/dxf转shp的程序或LISP，

Gu_xl

下面的程序就可以！

3. (defun C:MakeShape(/ f1 CT)
4.   (defun ShapeName (sfn / ofn n k k1 zc$ zc1$ spn zs ID_shape)
5.   (setq ofn (open sfn "r") n 0 ID_Shape '())
6.   (while (setq zc$ (read-line ofn))
7.     (if (eq (substr zc$ 1 1) "*")
8.       (progn
9. (setq n (1+ n) k (strlen zc$) k1 1 spn "" dh 0)
10. (repeat k
11.    (setq zc1$ (substr zc$ k1 1))
12.    (if (= zc1$ ";") (setq zs T zc1$ ""))
13.    (if (< dh 2)
14.      (if (eq "," zc1$) (setq dh (1+ dh)))
15.             (if zs
16.        ()
17.        (setq spn (strcat spn zc1$))
18.        )
19.      );if
20.    (setq k1 (1+ k1))
21.    );repeat
22. (if (/= "" spn) (setq ID_Shape (cons spn ID_Shape)))
23. );progn
24.       );if
25.     );while
26.   (close ofn)
27.   (setq ID_Shape (reverse ID_Shape))
28.   )
29.   ;(setIerr)
30.   (setq CT T)
31.   (while (not (setq fina1 (getfiled "形文件名" "" "shp" 1)))
32.         (abcdefg)
33.      )
34.     (if (setq f1 (open fina1 "r"))
35. (progn
36.     (setq ID_Shape (shapeName fina1))
37.     (close f1)
38.     );progn
39.     (setq ID_Shape '())
40.     );if
41. (setq fs (open fina1 "a"))
42.   (while Ct
43.     (setq su (1+ (length ID_SHAPE)))
44. ; (princ su)
45. ;(princ (strcat "\nNumber = " (itoa su)))
46.   (while (= "" (setq fina (strcase (getstring "\n请输入拟生成的形名 : "))))
47.          (alert "\n请输入拟生成的形名 : ")
48.       )
49.   (while (member fina ID_Shape)
50.     (PrinC "\n这个形名已经存在了!")
51.       (while (= "" (setq fina (strcase (getstring "\n请重新起名..."))))
52.          (alert "\n请输入拟生成的形名 : ")
53.       )
54.     )
55.   (setq ID_SHAPE (cons fina ID_SHAPE))
56.   (if (> (length ID_SHAPE) 255) (abcdefg))
57.   
58.   ;|(while (not (setq su (getint "\n请输入拟生成的形文件编号(1 - 255) :")))
59.          (alert "\n请输入拟生成的形文件编号(1 - 255) :")
60.        )
61.        |;
62.   (setq fst nil snd nil k 0 p1 nil)
63.   (setq fst (getpoint "\n请输入欲生成形文件的图形区域的一个角点 : "))
64.   (setq snd (getcorner fst "\n请输入欲生成形文件的图形区域的另一个角点 : "))
65.   (initget 7 "Yes No  ")
66.   (setq a$ (strcase (getKword "\n坐标值为整数吗?(Yes/No)<N>")))
67.   (if (= a$ "") (setq a$ "No"))
68.   (if (= a$ "Yes")
69.     (setq k1$ 125)
70.     (progn
71.       (setq k$ (distance fst snd))
72.       (setq p1 (getpoint "\n最长图形目标的一个端点 :"))
73.       (if (/= p1 nil)
74.               (setq k1$ (getdist p1 "\n最长图形目标的另一个端点 :"))
75.               (setq k1$ k$)
76. )
77.       )
78.     )
79.   (setq dd$ (fix (/ 125 k1$)))
80.   (setq dd$ (if (= dd$ 0) 1 dd$))
81.   (if (> dd$ 125) (setq dd$ 125))
82.   (setq a (ssget "c" fst snd))
83.   (setq count 3)
84.   (setq nu (sslength a))
85.   (while (< k nu)
86.     (setq enta (entget (ssname a k)))
87.     (setq b$ (cdr (assoc 0 enta)))
88.     (if (or (= b$ "POLYLINE") (= b$ "LWPOLYLINE"))
89.       (explo)
90.       (if (= b$ "BLOCK")
91. (explo)
92. (if (= b$ "INSERT")
93.    (explo)
94.    )
95. )
96.       )
97.     (setq k (1+ k))
98.     )
99.   (setq k 0)
100.   (setq a (ssget "c" fst snd))
101.   (setq nu (sslength a))
102.   (while (< k nu)
103.     (setq enta (entget (ssname a k)))
104.     (setq b$ (cdr (assoc 0 enta)))
105.     (if (= b$ "LINE")
106.       (setq count (+ 8 count))
107.       (if (= b$ "ARC")
108. (setq count (+ 15 count))
109. (if (= b$ "VERTEX")
110.    (setq count (+ 2 count))
111.    (if (= b$ "CIRCLE")
112.      (setq count (+ 12 count))
113.      )
114.    )
115. )
116.       )
117.     (setq k (1+ k))
118.     )
119.   ;(setq fina1 (getfiled "形文件名" "" "shp" 1))
120. ; (setq fs (open fina1 "a"))
121.   (setq b$ (strcat "*" (itoa su) "," (itoa count) "," fina))
122.   (write-line b$ fs)
123.   (setq a$ (strcat "3," (itoa dd$) ","))
124.   (write-line a$ fs)
125.   ;(setq p3 (cdr (assoc 10 (entget (ssname a 0)))))
126.   (setq p3 (getpoint "\n选择插入基点 :"))
127.   (setq k 0)
128.   (while (< k nu)
129.     (setq e (entget (ssname a k)))
130.     (setq estr (cdr (assoc 0 e)))
131.     (if (= estr "LINE")
132.       (progn
133. (setq p1 (cdr (assoc 10 e)))
134. (setq dx1 (fix1 (mul (- (car p1) (car p3)))))
135. (setq dy1 (fix1 (mul (- (cadr p1) (cadr p3)))))
136. (setq p2 (cdr (assoc 11 e)))
137. (setq dx (fix1 (mul (- (car p2) (car p1)))))
138. (setq dy (fix1 (mul (- (cadr p2) (cadr p1)))))
139. (setq a$ (strcat "2,8," (itoa dx1) "," (itoa dy1) ","))
140. (setq b$ (strcat "1,8," (itoa dx) "," (itoa dy) ","))
141. (setq c$ (strcat a$ b$))
142. (write-line c$ fs)
143. (setq p3 p2)
144. )
145.       (if (= estr "CIRCLE")
146. (progn
147.    (setq p1 (cdr (assoc 10 e)))
148.    (setq r1 (cdr (assoc 40 e)))
149.    (setq r (fix (+ 0.5 (mul r1))))
150.    (setq dx (fix1 (mul (+ r1 (- (car p1) (car p3))))))
151.    (setq dy (fix1 (mul (- (cadr p1) (cadr p3)))))
152.    (setq a$ (strcat "2,8," (itoa dx) "," (itoa dy) ","))
153.    (setq b$ (strcat "1,10,(" (itoa r) ",000),"))
154.    (setq c$ (strcat "2,8,-" (itoa r) ",0"))
155.    (write-line (strcat a$ b$ c$) fs)
156.    (setq p3 p1)
157.    )
158. (if (= estr "ARC")
159.    (progn
160.      (setq p1 (cdr (assoc 10 e)))
161.      (setq sa1 (cdr (assoc 50 e)))
162.      (setq ea1 (cdr (assoc 51 e)))
163.      (setq r1 (cdr (assoc 40 e)))
164.      (setq dx (fix1 (mul (+ (* r1 (cos sa1))
165.        (- (car p1) (car p3))))))
166.      (setq dy (fix1 (mul (+ (* r1 (sin sa1))
167.     (- (cadr p1) (cadr p3))))))
168.      (setq r (fix (+ 0.5 (mul r1))))
169.      (setq sad (rtd sa1) ead (rtd ea1))
170.      (setq saa (/ sad 45))
171.      (setq eaa (/ ead 45))
172.      (setq sa0 (fix saa) ea0 (fix eaa))
173.      (setq sa (fix (+ 0.5 (/ (* (rem sad 45) 256) 45))))
174.      (setq ea (fix (+ 0.5 (/ (* (rem ead 45) 256) 45))))
175.      (if (= 0 (rem ead 45))
176.        (setq ea0 (1- ea0))
177.        )
178.      (if (= 256 sa)
179.        (setq sa 0 sa0 (1+ sa0))
180.        )
181.      (if (= 256 ea)
182.        (setq ea 0)
183.        )
184.      (if (> sad ead)
185.        (setq c (+ 9 (- ea0 sa0)))
186.        (setq c (+ 1 (- ea0 sa0)))
187.        )
188.      (if (= 8 sa0) (setq sa0 0))
189.      (if (> r (* dd$ 255))
190.        (setq rr r)
191.        (setq rr 0)
192.        )
193.      (setq a$ (strcat "2,8,"
194.         (itoa dx) ","
195.         (itoa dy) ","))
196.      (setq b$ (strcat "1,11,("
197.         (itoa sa) ","
198.         (itoa ea) ","
199.         (itoa rr) ","
200.         (itoa r) ",0"
201.         (itoa sa0)
202.         (itoa c) "),"))
203.      (setq dx1 (- 0 (fix1 (mul (* r1 (cos ea1))))))
204.      (setq dy1 (- 0 (fix1 (mul (* r1 (sin ea1))))))
205.      (setq c$ (strcat "2,8,"
206.         (itoa dx1) ","
207.         (itoa dy1) ","))
208.      (write-line (strcat a$ b$ c$) fs)
209.      (setq p3 p1)
210.      )
211.    )
212. )
213.       )
214.     (setq k (1+ k))
215.     )
216.     (write-line "0" fs)
217.     (initget 7 "Yes No  ")
218.     (setq k$ (getkword "\n继续制作形文件?[<Yes>/<No>]<Yes>:"))
219.     (if (or (= "Yes" k$) (= "" K$))
220.       (setq CT T)
221.       (setq CT nil)
222.       )
223.     );while
224.   (close fs)
225.   ;(reerr)
226.   )

(defun C:MakeShape(/ f1 CT)   (defun ShapeName (sfn / ofn n k k1 zc$ zc1$ spn zs ID_shape)   (setq ofn (open sfn "r") n 0 ID_Shape '())   (while (setq zc$ (read-line ofn))     (if (eq (substr zc$ 1 1) "*")       (progn (setq n (1+ n) k (strlen zc$) k1 1 spn "" dh 0) (repeat k    (setq zc1$ (substr zc$ k1 1))    (if (= zc1$ ";") (setq zs T zc1$ ""))    (if (< dh 2)      (if (eq "," zc1$) (setq dh (1+ dh)))             (if zs        ()        (setq spn (strcat spn zc1$))        )      );if    (setq k1 (1+ k1))    );repeat (if (/= "" spn) (setq ID_Shape (cons spn ID_Shape))) );progn       );if     );while   (close ofn)   (setq ID_Shape (reverse ID_Shape))   )   ;(setIerr)   (setq CT T)   (while (not (setq fina1 (getfiled "形文件名" "" "shp" 1)))         (abcdefg)      )     (if (setq f1 (open fina1 "r")) (progn     (setq ID_Shape (shapeName fina1))     (close f1)     );progn     (setq ID_Shape '())     );if (setq fs (open fina1 "a"))   (while Ct     (setq su (1+ (length ID_SHAPE))) ; (princ su) ;(princ (strcat "\nNumber = " (itoa su)))   (while (= "" (setq fina (strcase (getstring "\n请输入拟生成的形名 : "))))          (alert "\n请输入拟生成的形名 : ")       )   (while (member fina ID_Shape)     (PrinC "\n这个形名已经存在了!")       (while (= "" (setq fina (strcase (getstring "\n请重新起名..."))))          (alert "\n请输入拟生成的形名 : ")       )     )   (setq ID_SHAPE (cons fina ID_SHAPE))   (if (> (length ID_SHAPE) 255) (abcdefg))      ;|(while (not (setq su (getint "\n请输入拟生成的形文件编号(1 - 255) :")))          (alert "\n请输入拟生成的形文件编号(1 - 255) :")        )        |;   (setq fst nil snd nil k 0 p1 nil)   (setq fst (getpoint "\n请输入欲生成形文件的图形区域的一个角点 : "))   (setq snd (getcorner fst "\n请输入欲生成形文件的图形区域的另一个角点 : "))   (initget 7 "Yes No  ")   (setq a$ (strcase (getKword "\n坐标值为整数吗?(Yes/No)<N>")))   (if (= a$ "") (setq a$ "No"))   (if (= a$ "Yes")     (setq k1$ 125)     (progn       (setq k$ (distance fst snd))       (setq p1 (getpoint "\n最长图形目标的一个端点 :"))       (if (/= p1 nil)               (setq k1$ (getdist p1 "\n最长图形目标的另一个端点 :"))               (setq k1$ k$) )       )     )   (setq dd$ (fix (/ 125 k1$)))   (setq dd$ (if (= dd$ 0) 1 dd$))   (if (> dd$ 125) (setq dd$ 125))   (setq a (ssget "c" fst snd))   (setq count 3)   (setq nu (sslength a))   (while (< k nu)     (setq enta (entget (ssname a k)))     (setq b$ (cdr (assoc 0 enta)))     (if (or (= b$ "POLYLINE") (= b$ "LWPOLYLINE"))       (explo)       (if (= b$ "BLOCK") (explo) (if (= b$ "INSERT")    (explo)    ) )       )     (setq k (1+ k))     )   (setq k 0)   (setq a (ssget "c" fst snd))   (setq nu (sslength a))   (while (< k nu)     (setq enta (entget (ssname a k)))     (setq b$ (cdr (assoc 0 enta)))     (if (= b$ "LINE")       (setq count (+ 8 count))       (if (= b$ "ARC") (setq count (+ 15 count)) (if (= b$ "VERTEX")    (setq count (+ 2 count))    (if (= b$ "CIRCLE")      (setq count (+ 12 count))      )    ) )       )     (setq k (1+ k))     )   ;(setq fina1 (getfiled "形文件名" "" "shp" 1)) ; (setq fs (open fina1 "a"))   (setq b$ (strcat "*" (itoa su) "," (itoa count) "," fina))   (write-line b$ fs)   (setq a$ (strcat "3," (itoa dd$) ","))   (write-line a$ fs)   ;(setq p3 (cdr (assoc 10 (entget (ssname a 0)))))   (setq p3 (getpoint "\n选择插入基点 :"))   (setq k 0)   (while (< k nu)     (setq e (entget (ssname a k)))     (setq estr (cdr (assoc 0 e)))     (if (= estr "LINE")       (progn (setq p1 (cdr (assoc 10 e))) (setq dx1 (fix1 (mul (- (car p1) (car p3))))) (setq dy1 (fix1 (mul (- (cadr p1) (cadr p3))))) (setq p2 (cdr (assoc 11 e))) (setq dx (fix1 (mul (- (car p2) (car p1))))) (setq dy (fix1 (mul (- (cadr p2) (cadr p1))))) (setq a$ (strcat "2,8," (itoa dx1) "," (itoa dy1) ",")) (setq b$ (strcat "1,8," (itoa dx) "," (itoa dy) ",")) (setq c$ (strcat a$ b$)) (write-line c$ fs) (setq p3 p2) )       (if (= estr "CIRCLE") (progn    (setq p1 (cdr (assoc 10 e)))    (setq r1 (cdr (assoc 40 e)))    (setq r (fix (+ 0.5 (mul r1))))    (setq dx (fix1 (mul (+ r1 (- (car p1) (car p3))))))    (setq dy (fix1 (mul (- (cadr p1) (cadr p3)))))    (setq a$ (strcat "2,8," (itoa dx) "," (itoa dy) ","))    (setq b$ (strcat "1,10,(" (itoa r) ",000),"))    (setq c$ (strcat "2,8,-" (itoa r) ",0"))    (write-line (strcat a$ b$ c$) fs)    (setq p3 p1)    ) (if (= estr "ARC")    (progn      (setq p1 (cdr (assoc 10 e)))      (setq sa1 (cdr (assoc 50 e)))      (setq ea1 (cdr (assoc 51 e)))      (setq r1 (cdr (assoc 40 e)))      (setq dx (fix1 (mul (+ (* r1 (cos sa1))        (- (car p1) (car p3))))))      (setq dy (fix1 (mul (+ (* r1 (sin sa1))     (- (cadr p1) (cadr p3))))))      (setq r (fix (+ 0.5 (mul r1))))      (setq sad (rtd sa1) ead (rtd ea1))      (setq saa (/ sad 45))      (setq eaa (/ ead 45))      (setq sa0 (fix saa) ea0 (fix eaa))      (setq sa (fix (+ 0.5 (/ (* (rem sad 45) 256) 45))))      (setq ea (fix (+ 0.5 (/ (* (rem ead 45) 256) 45))))      (if (= 0 (rem ead 45))        (setq ea0 (1- ea0))        )      (if (= 256 sa)        (setq sa 0 sa0 (1+ sa0))        )      (if (= 256 ea)        (setq ea 0)        )      (if (> sad ead)        (setq c (+ 9 (- ea0 sa0)))        (setq c (+ 1 (- ea0 sa0)))        )      (if (= 8 sa0) (setq sa0 0))      (if (> r (* dd$ 255))        (setq rr r)        (setq rr 0)        )      (setq a$ (strcat "2,8,"         (itoa dx) ","         (itoa dy) ","))      (setq b$ (strcat "1,11,("         (itoa sa) ","         (itoa ea) ","         (itoa rr) ","         (itoa r) ",0"         (itoa sa0)         (itoa c) "),"))      (setq dx1 (- 0 (fix1 (mul (* r1 (cos ea1))))))      (setq dy1 (- 0 (fix1 (mul (* r1 (sin ea1))))))      (setq c$ (strcat "2,8,"         (itoa dx1) ","         (itoa dy1) ","))      (write-line (strcat a$ b$ c$) fs)      (setq p3 p1)      )    ) )       )     (setq k (1+ k))     )     (write-line "0" fs)     (initget 7 "Yes No  ")     (setq k$ (getkword "\n继续制作形文件?[<Yes>/<No>]<Yes>:"))     (if (or (= "Yes" k$) (= "" K$))       (setq CT T)       (setq CT nil)       )     );while   (close fs)   ;(reerr)   )

MJTD_7777

网上好像有软件

phg

用Autodesk Map 2004可以实现

很方便的

laoxie_198

我自己写了个，根据二调的数据格式。可以像cass中一样绘制各种地物符号，然后转到shp中。

可以根据你的需求修改。

我的qq147828493，

邮箱：laoxie_1983@126.com

anwei003

我也想要！

anwei003

呵呵!其实我也写了一个！采用VBA写的！简单明了！有意向可以联系我！

qq：695705993

邮箱：anwei003@126.com

spursand

你好.本人在做一个dwg转shp的程序,毫无头绪,请指教一下.

nxy_918

楼上搞错了吧