[求助]dwg2shp
<P>明经网站上有一个dwg转shp字体的软件，不知为何，不能下载。</P><P>大家有没有这个软件阿？传我一份，谢谢，最好有专家写成lisp，我学习一下。</P>
<P>如有，麻烦发至<A href="mailto:hwang21@163.com" target="_blank" >hwang21@163.com</A>，如果是exe文件，记得压缩一下，或者改扩展名，我的邮箱不允许发送接受可执行文件，会识别为病毒。</P> <P>怎么没有人帮我？没有人有这个小软件吗？</P>
<P>顶上去，沉下去更没有希望了</P>
;###############################################################
;##图形转换到形文件功能软件3．0版 DWG-SHP.LSP ##
;##适用于 AutoCAD R13以上版 ##
;##可转换的实体类型: 直线 _________ Line ##
;## 圆弧 _________ Arc ##
;## 圆 ___________ Circle ##
;## ##
;##限制条件: 1> 每个端点都应尽量落在 1mm 的隐含网格上 ##
;## 2> 同一实体的两个相邻点 X,Y 位移小于 127mm ##
;## 3> 直线中大于 127mm 的部分应分为 127mm 的几段##
;## 4> 大于半圆的弧应分两段绘成,半径应是整数 ##
;## 5> 尽量少用 Arc，非用不可，应在最后绘成 , ##
;###############################################################
;-- ERROR 错误中断处理 --------------------------------------------
(Defun CPrint (ipl / in)
(SetQ in 0)
(While (SetQ ipa (Nth in ipl))
(If (= 'REL (Type ipa)) (PrinC (RToS ipa)) (PrinC ipa))
(SetQ in (1+ in))
)
(PrinC)
)
(Defun Error (ex2 ey2 ex1 ey1 est / ea exx eyy)
(SetQ ea (Angle (List ex1 ey1) (List ex2 ey2))
exx (* 4 (Sin ea)) eyy (* 4 (Cos ea))
)
(GrDraw (List ex1 ey1) (List (- ex2 exx)(+ ey2 eyy)) 1 1)
(GrDraw (List (- ex2 exx)(+ ey2 eyy))
(List (+ ex2 exx)(- ey2 eyy)) 1 1)
(GrDraw (List (+ ex2 exx)(- ey2 eyy))(List ex1 ey1) 1 1)
(If (/= nil ofn3) (Close ofn3))
(If (/= nil ofn2) (Close ofn2))
(If (/= nil ofn1) (Close ofn1))
(Alert (StrCat "\n注意: \n" est "\n请重新修改你的图形，再试一次..."))
(SetQ ex1 nil ey1 nil ex2 ni ey2 nil)
(Redraw)(Abcdefg)
)
;-- 2,8,(dx,dy), 空移的描述和处理 ---------------------------------
(Defun 2-XY()
(SetQ 2a (Angle (List x0 y0)(List x1 y1))
2xx (* 2 (Sin 2a)) 2yy (* 2 (Cos 2a))
)
(GrDraw (List x1 y1) (List (- x0 2xx)(+ y0 2yy)) 3 1)
(GrDraw (List (- x0 2xx)(+ y0 2yy))
(List (+ x0 2xx)(- y0 2yy)) 3 1)
(GrDraw (List (+ x0 2xx)(- y0 2yy))(List x1 y1) 3 1)
(SetQ 2dx (- x1 x0) 2dy (- y1 y0) ax (Abs 2dx) ay (Abs 2dy))
(If (> 0.3 ax)(SetQ ax 0.0))
(If (> 0.3 ay)(SetQ ay 0.0))
(If (>= 2dx 0)(SetQ xfh "+")(SetQ xfh "-"))
(If (>= 2dy 0)(SetQ yfh "+")(SetQ yfh "-"))
(Cond ((Or (/= 0 2dx)(/= 0 2dy)) ;-> cond1
(Cond ((Or (> ax 127)(> ay 127)) ;-> cond1-1
(Cond ((= ax ay) ;-> cond1-2
(SetQ dn (RToS (/ ax 127) 2 0)
ddd (RToS (rem ax 127) 2 0)
sdy (StrCat "2,4," dn
",8,(" xfh "127," yfh "127,)"
"3," dn
",8,(" xfh ddd "," yfh ddd "),1,"
)
sdyl (+ sdyl 12)
)
(Write-Line sdy ofn2) (SetQ sdy "")
) ;> ax=ay end
((= ax 0)
(SetQ dn (RToS (/ ay 127) 2 0)
ddd (RToS (rem ay 127) 2 0)
sdy (StrCat "2,4," dn
",8,(0," yfh "127,)"
"3," dn
",8,(0," yfh ddd "),1,"
)
sdyl (+ sdyl 12)
)
(Write-Line sdy ofn2) (SetQ sdy "")
);> ax=0 end
((= ay 0)
(SetQ dn (RToS (/ ax 127) 2 0)
ddd (RToS (rem ax 127) 2 0)
sdy (StrCat "2,4," dn
",8,(" xfh "127,0),"
"3," dn
",8,(" xfh ddd ",0),1,"
)
sdyl (+ sdyl 12)
)
(Write-Line sdy ofn2) (SetQ sdy "")
) ;> ay=0 end
(T (Error x0 y0 x1 y1 "距离太长"))
) ;> cond1-2 end
) ;> ax or ay > 127 end
(T (SetQ sdy (StrCat "2,8,(" (RToS 2dx 2 0) ","
(RToS 2dy 2 0) "),1,"
)
sdyl (+ sdyl 5)
)
(Write-Line sdy ofn2)
) ;> ax and ay < 127 end
);> cond1-1 end
)) ;> cond1 end
(SetQ 2dx nil 2dy nil ddd nil xfh nil yfh nil))
;-- ARC 弧实体的转换 ----------------------------------------------
(Defun S-Arc()
(PrinC "A.")
(SetQ cr (Cdr (Assoc 40 ent))
x (Cadr (Assoc 10 ent)) y (Caddr (Assoc 10 ent))
a1 (Cdr (Assoc 50 ent)) a2 (Cdr (Assoc 51 ent))
a11 (AToF (angtos a1 0 3)) a22 (AToF (angtos a2 0 3))
x1 (+ x (* cr (Cos a1))) y1 (+ y (* cr (Sin a1)))
x2 (+ x (* cr (Cos a2))) y2 (+ y (* cr (Sin a2)))
dx (- x2 x1) dy (- y2 y1)
)
(2-xy)
(Cond ((And (< (Abs dx) 127.0) (< (Abs dy) 127.0))
(setq d ( sqrt (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) ))
h (- cr ( sqrt (- (* cr cr) (* 0.25 d d))))
td(* (/ (* 2.0 H) D) 127.0)
)
(setq dx (rtos dx 2 0) dy (rtos dy 2 0) td (rtos td 2 0) )
(SetQ sdy (StrCat "12," dx "," dy "," td ",")
sdyl (+ sdyl 4)
)
(Write-Line sdy ofn2)
; (princ sdy)
(SetQ sdy "" x0 x2 y0 y2)
);-> cond T end
(T (Error x1 y1 x2 y2 "弧线太长 <S-Line>"))
);-> cond end
)
;-- CIRCLE 圆实体的转换 -------------------------------------------
(Defun S-Circle()
(PrinC "C.")
(SetQ cr (Cdr (Assoc 40 ent))
x1 (+ cr (Cadr (Assoc 10 ent))) y1 (Caddr (Assoc 10 ent))
cr (RToS cr 2 0)
)
(2-XY)
; (SetQ sdy (StrCat "4," cr ",7,1,3," cr ",") sdyl (+ sdyl 6))
(SetQ sdy (StrCat "10," cr ",000," ) sdyl (+ sdyl 3))
(Write-Line sdy ofn2)(SetQ sdy "" x0 x1 y0 y1 cr nil)
)
;-- LINE 直线实体的转换 -------------------------------------------
(Defun S-Line()
(PrinC "L.")
(SetQ x1 (Cadr (Assoc 10 ent)) y1 (Caddr (Assoc 10 ent))
x2 (Cadr (Assoc 11 ent)) y2 (Caddr (Assoc 11 ent))
dx (- x2 x1) dy (- y2 y1)
ddx (RToS dx 2 0) ddy (RToS dy 2 0)
)
(2-XY)
(Cond ((And (< (Abs dx) 127) (< (Abs dy) 127))
(SetQ sdy (StrCat "8,(" ddx "," ddy "),") sdyl (+ sdyl 3))
(Write-Line sdy ofn2)
; (princ sdy)
(SetQ sdy "" x0 x2 y0 y2)
);-> cond T end
(T (Error x1 y1 x2 y2 "线太长 <S-Line>"))
);-> cond end
(SetQ dx nil dy nil ddx nil ddy nil)
)
;-- Write to SHP file 填写形文件 ----------------------------------
(Defun Write-SHP()
(PrinC "\n正在写入形定义源文件...")
(Close ofn2)(SetQ ofn2 (open sfn2 "r") ofn1 (open sfn1 "a"))
(SetQ odyl (RToS (1+ sdyl) 2 0) osno (RToS sno 2 0)
obtl (StrCat "*" osno "," (rtos (+ 4 (atoi odyl)) 2 0) "," sna)
)
(Write-Line obtl ofn1)
(Write-Line "07,1," ofn1)
(While (SetQ txt (read-line ofn2)) (Write-Line txt ofn1))
(Write-Line "07,2,0" ofn1)
;(Write-Line "0" ofn1)
; (Write-Line sna ofn3)
(Close ofn1) (Close ofn2) (Close ofn3)
(SetQ odyl nil odtl nil)
)
;-- found *.nam file 形名索引的检索处理 & 输入限制 ----------------
(Defun Name-File()
(SetQ ofn3 (Open sfn3 "r"))
(While (SetQ rsna (Read-Line ofn3))
(Cond ((= rsna sna)
(PrinC "\n这个形名已经存在了!")
(SetQ sna (GetString" 形名: ") sna (StrCase sna))
(While (Or (Eq "" sna)(= "SAVE" sna)(= rsna sna))
(PrinC "\n请重新起名...")
(SetQ sna (GetString" 名: ") sna (StrCase sna))
)
(Close ofn3)
(SetQ ofn3 (Open sfn3 "r"))
);-> (= rsna sna)
) ;-> cond end
);-> while end
(Close ofn3)
(SetQ ofn3 (Open sfn3 "a"))
)
;== DWG to SHP 图 --> 形转换功能的主控段落 ======================
;(Defun C:DWG-SHP ()
(Defun C:DS ()
; (Defun *error* (st) (SetQ *error* nil) (PrinC))
(SetQ sfn0 (GetString"\n形文件名: "));-> Input Filename
(While (Eq sfn0 "");-> "RETURN" err
(SetQ sfn0 (GetString"\n请确定形文件名: "))
);-> while end
(SetQ sfn1 (StrCat sfn0 ".SHP")
sfn2 (StrCat sfn0 ".BAK")
sfn3 (StrCat sfn0 ".NAM") sdy ""
)
(If (SetQ ofn3 (Open sfn3 "r"));-> new or old file
(Progn (SetQ sno 1)
(While (Read-Line ofn3) (SetQ sno (1+ sno)))
(PrinC "已有的形定义源文件...")(Close ofn3)
)
(Progn (SetQ ofn1 (Open sfn1 "w") ofn3 (Open sfn3 "w"))
(Write-Line "C" ofn3)(Close ofn3)
(Write-Line "*1,9,C" ofn1)
(Write-Line "2,010,1,10,1,000,2,018,0" ofn1)
(PrinC "新文件...") (SetQ sno 2)(Close ofn1)
)
)
(CPrint (List "\n形定义 [" sno))
(SetQ sna (StrCase (GetString"] 名: ")))
(While (Eq "" sna)
(SetQ sna (StrCase (GetString" 请输入形定义名: ")))
)
(While (And (/= "SAVE" sna)(> 255 sno));-> big while start
(SetQ ofn2 (Open sfn2 "w") sdyl 0)
(Name-File)
(SetQ ;inp (getpoint"\n插入基点: ")
x0 (Car inp) y0 (Cadr inp) inp nil
x0 0y0 0
)
(PrinC "\n请选定要转换成形定义的图线 ...")
(SetQ ss (ssget))
(If (/= nil ss) (SetQ ssn (sslength ss)) (SetQ ssn 0))
(While (Or (Eq nil ss) (> ssn 1200))
(PrinC "\n所选的图线个数是 ")
(PrinC (RToS ssn 2 0))
(PrinC "\n但是，图线数量限制在 1到 100之间！<dwg-shp>")
(SetQ ss (ssget))
(If (/= nil ss) (SetQ ssn (sslength ss)) (SetQ ssn 0))
)
(SetQ n (- ssn 1))
(repeat ssn
(SetQ ent (EntGet (ssname ss n))
etype (Cdr (Assoc 0 ent))
)
(Cond ((= etype "LINE")(S-Line))
((= etype "ARC")(S-Arc))
((= etype "CIRCLE")(S-Circle))
(T (SetQ errp (Cdr (Assoc 10 ent))
errx (Car errp)
erry (Cadr errp)
)
(Error errx erry (+ errx 10) erry
(StrCat "所指图线中有不能转换的 " etype
"\n 能够转换的对象是:"
" Line、Circle 和 Arc"
)
)
)
)
(SetQ n (1- n))
)
(SetQ sno (1+ sno))(Write-SHP)
(PrinC "\nSAVE(存盘）/<形定义[") (PrinC sno)
(SetQ sna (StrCase (GetString"]名>: ")))
(While (Eq "" sna)
(SetQ sna (StrCase (GetString" 请输入形定义名: ")))
)
);-> big while end
(PrinC "\n形文件: ")(PrinC (StrCase sfn0))
(PrinC ".SHP 已经存好了。")
(PrinC "\n感谢您使用我的程序，再见！")
(PrinC)
)
;== By Chen Bo xiong =========================================================
谢谢，很好用 <p class="MsoBodyText" style="MARGIN: 0cm 0cm 0pt;"><font face="Verdana" size="2">如题。就是如何使用lsp将dwg文件中的实体坐标写到txt文件中，然后将经过平常以后的txt中的实体坐标写入到dwg文件中。</font></p>
页:
[1]