[求助]：绘制断面图.lsp文件

zzlphp

我是一线路设计员，测量玩后，想用CAD画断面图，不知哪位高手能帮忙谢谢了，我还想要一画铁路的小程序。
我的邮箱是zzlphp6225519@163.com
谢谢了

david96007

说明：
需要的几个图层：_duanmian（断面位置线及断面线的图层）、Dx-dgx（等高线的图层）；
等高线要有高程，我用的单位是mm；
如果等高线是pline线，程序将炸开为line，请事先备份原文件！
要画断面，先在断面位置处画“断面位置线”（line）；
程序运行后，提示“请选择断面:”，“点取断面图左下角点位置(不移动断面图直接回车):”；
程序中设置了一个相对标高：290000mm；断面线将以此相对标高绘制；
断面线以line绘制出后组成无名组，断面位置线与等高线相交处绘制了垂直线，也组成无名组！

2. 
   
3. (defun c:dm (/            cmd           dmx          sp         ep        sp_ucs ep_ucs ang
   
4.              ang1   ss1           ss2          sslst         sslen        inters_p_l    n
   
5.              ent    sp1           ep1          sp2         ep2        pt3    os     uf
   
6.              cly    pt4           inters_p         xdgch        gro1   gro2   pt_0
   
7.              pt_0_t pt_n   pt_n_t
   
8.             )
   
9.   (defun set_ini ()
   
10.     (setq cmd (GETVAR "cmdecho")
    
11.           os  (GETVAR "OSMODE")
    
12.           uf  (getvar "UCSFOLLOW")
    
13.           cly (getvar "CLAYER")
    
14.     ) ;_ end of setq
    
15.     (setvar "cmdecho" 0)
    
16.     (setvar "osmode" 0)
    
17.     (setvar "UCSFOLLOW" 0)
    
18.     (setvar "CLAYER" "_duanmian")
    
19.   ) ;_ end of defun
    
20.   (defun err_new (msg) (princ msg) (set_close)) ;_ end of defun
    
21.   (defun set_close ()
    
22.     (setvar "OSMODE" os)
    
23.     (setvar "cmdecho" cmd)
    
24.     (setvar "UCSFOLLOW" uf)
    
25.     (setvar "CLAYER" cly)
    
26.     (setq *error* err_old)
    
27.   ) ;_ end of defun
    
28.   (setq        err_old        *error*
    
29.         *error*        err_new
    
30.   ) ;_ end of setq
    
31.   (set_ini)
    
32.   (setq xdgch 290000);相对高程
    
33.   (setq dmx (car (nentsel "请选择断面:")))
    
34.   (command "_.ucsicon" "off")
    
35.   (command "_.ucs" "ob" dmx)
    
36.   (setq        sp     (cdr (assoc 10 (entget dmx)))
    
37.         ep     (cdr (assoc 11 (entget dmx)))
    
38.         sp_ucs (trans sp 0 1)
    
39.         ep_ucs (trans ep 0 1)
    
40.         ang    (angle sp_ucs ep_ucs)
    
41.   ) ;_ end of setq
    
42.   (if (and (> ang (/ pi 2)) (< ang (* pi 1.5)))
    
43.     (setq ang1 (* pi 1.5))
    
44.     (setq ang1 (/ pi 2))
    
45.   ) ;_ end of if
    
46.   (setq        ss1 (ssget "f"
    
47.                    (list sp_ucs ep_ucs)
    
48.                    '((8 . "Dx-dgx") (0 . "LWPOLYLINE"))
    
49.             ) ;_ end of ssget
    
50.   ) ;_ end of setq
    
51.   (if (/= ss1 nil)
    
52.     (progn (command "qaflags" 1) (command "_.explode" ss1 ""))
    
53.   ) ;_ end of if
    
54.   (setq        ss2 (ssget "f"
    
55.                    (list sp_ucs ep_ucs)
    
56.                    '((8 . "Dx-dgx") (0 . "line"))
    
57.             ) ;_ end of ssget
    
58.   ) ;_ end of setq
    
59.   (setq        sslen           (sslength ss2)
    
60.         sslst           nil
    
61.         n           0
    
62.         inters_p_l nil
    
63.   ) ;_ end of setq
    
64.   (while (< n sslen)
    
65.     (setq ent (ssname ss2 n))
    
66.     (setq sp1 (cdr (assoc 10 (entget ent)))
    
67.           ep1 (cdr (assoc 11 (entget ent)))
    
68.           sp2 (list (car sp1) (cadr sp1) (caddr sp))
    
69.           ep2 (list (car ep1) (cadr ep1) (caddr ep))
    
70.     ) ;_ end of setq
    
71.     (setq inters_p (inters sp ep sp2 ep2))
    
72.     (setq inters_p_l
    
73.            (cons (list inters_p (caddr sp1)) inters_p_l) ;_ end of cons
    
74.     ) ;_ end of setq
    
75.     (setq n (1+ n))
    
76.   ) ;_ end of while
    
77.   (setq        ll     (length inters_p_l)
    
78.         n      1
    
79.         sp_ucs (trans sp 0 1)
    
80.         ep_ucs (trans ep 0 1)
    
81.   ) ;_ end of setq
    
82.   (setq        pt_0   (trans (car (nth 0 inters_p_l)) 0 1)
    
83.         h      (car (cdr (nth 0 inters_p_l)))
    
84.         pt_0_t (polar pt_0 ang1 (- h xdgch))
    
85.         gro1   nil
    
86.         gro2   nil
    
87.   ) ;_ end of setq
    
88.   (command "_.line" pt_0 pt_0_t "")
    
89.   (setq gro1 (cons (entlast) gro))
    
90.   (while (< n ll)
    
91.     (setq pt_n         (trans (car (nth n inters_p_l)) 0 1)
    
92.           h         (car (cdr (nth n inters_p_l)))
    
93.           pt_n_t (polar pt_n ang1 (- h xdgch))
    
94.     ) ;_ end of setq
    
95.     (command "_.line" pt_n pt_n_t "")
    
96.     (setq gro1 (cons (entlast) gro1))
    
97.     (command "_.line" pt_0_t pt_n_t "")
    
98.     (setq gro2 (cons (entlast) gro2))
    
99.     (setq pt_0_t pt_n_t)
    
100.     (setq n (1+ n))
     
101.   ) ;_ end of while
     
102.   (command "_.line" pt_0 pt_n "")
     
103.   (setq        pt_0 (trans pt_0 1 0)
     
104.         pt_n (trans pt_n 1 0)
     
105.   ) ;_ end of setq
     
106.   (setq gro2 (cons (entlast) gro2))
     
107.   (command "_.ucs" "p")
     
108.   (command "_.ucsicon" "on")
     
109.   (dm:makgrp gro1 "In use by DuanMian")
     
110.   (dm:makgrp gro2 "In use by DuanMian")
     
111.   (setq
     
112.     pt3        (getpoint "\n点取断面图左下角点位置(不移动断面图直接回车):") ;_ end of getpoint
     
113.   ) ;_ end of setq
     
114.   (if (/= nil pt3)
     
115.     (progn (setq pt4  (polar pt3 0 xdgch)
     
116.                  pt_0 (trans pt_0 0 1)
     
117.                  pt_n (trans pt_n 0 1)
     
118.            ) ;_ end of setq
     
119.            (if (< (car pt_0) (car pt_n))
     
120.              (dm:align (append gro1 gro2) pt_0 pt3 pt_n pt4)
     
121.              (dm:align (append gro1 gro2) pt_n pt3 pt_0 pt4)
     
122.            ) ;_ end of if
     
123.     ) ;_ end of progn
     
124.   ) ;_ end of if
     
125.   (command "qaflags" 0)
     
126.   (set_close)
     
127.   (gc)
     
128.   (princ)
     
129. ) ;_ end of defun
     
130. 
     
131. (defun dm:makgrp (LST DESC / NAM EN LST GDICT GDATA)
     
132.   (setq
     
133.     NAM        (strcat "DuanMian" (substr (rtos (getvar "CDATE") 2 8) 10)) ;_ end of strcat
     
134.   ) ;_ end of setq
     
135.   (command "_.-group" "_create" NAM DESC)
     
136.   (foreach EN LST (command EN))
     
137.   (command "")
     
138.   (setq        GDICT (dictsearch (namedobjdict) "ACAD_GROUP")
     
139.         GDATA (dictsearch (cdr (assoc -1 GDICT)) NAM)
     
140.         GDATA (subst (cons 70 1) (assoc 70 GDATA) GDATA)
     
141.   ) ;_ end of setq
     
142.   (dictrename (cdr (assoc -1 GDICT)) NAM "*A")
     
143.   (entmod GDATA)
     
144. ) ;_ end of defun
     
145. 
     
146. 
     
147. (defun dm:align        (gro f_pt1 f_pt2 f_pt3 f_pt4 / en f_test f_osmode)
     
148.   (setq f_osmode -1)
     
149.   (if (not
     
150.         (or (null f_pt1) (null f_pt2) (null f_pt3) (null f_pt4)) ;_ end of or
     
151.       ) ;_ end of not
     
152.     (progn (if (< (getvar "osmode") 16384)
     
153.              (progn (setq f_osmode (getvar "osmode"))
     
154.                     (setvar "osmode" (+ f_osmode 16384))
     
155.              ) ;_ end of progn
     
156.            ) ;_ end of if
     
157.            (command "ucs" "z" f_pt2 f_pt4)
     
158.            (command "rotate")
     
159.            (foreach EN gro (command EN))
     
160.            (command "" f_pt1 "r" f_pt1 f_pt3 "0") ;_ end of command
     
161.            (command "ucs" "p")
     
162.            (command "move" "P" "" f_pt1 f_pt2)
     
163.            (if (/= f_osmode -1)
     
164.              (setvar "osmode" f_osmode)
     
165.            ) ;_ end of if
     
166.     ) ;_ end of progn
     
167.   ) ;_ end of if
     
168.   (princ)
     
169. ) ;_ end of defun
     

<br /> (defun c:dm (/            cmd           dmx          sp         ep        sp_ucs ep_ucs ang<br />              ang1   ss1           ss2          sslst         sslen        inters_p_l    n<br />              ent    sp1           ep1          sp2         ep2        pt3    os     uf<br />              cly    pt4           inters_p         xdgch        gro1   gro2   pt_0<br />              pt_0_t pt_n   pt_n_t<br />             )<br />   (defun set_ini ()<br />     (setq cmd (GETVAR "cmdecho")<br />           os  (GETVAR "OSMODE")<br />           uf  (getvar "UCSFOLLOW")<br />           cly (getvar "CLAYER")<br />     ) ;_ end of setq<br />     (setvar "cmdecho" 0)<br />     (setvar "osmode" 0)<br />     (setvar "UCSFOLLOW" 0)<br />     (setvar "CLAYER" "_duanmian")<br />   ) ;_ end of defun<br />   (defun err_new (msg) (princ msg) (set_close)) ;_ end of defun<br />   (defun set_close ()<br />     (setvar "OSMODE" os)<br />     (setvar "cmdecho" cmd)<br />     (setvar "UCSFOLLOW" uf)<br />     (setvar "CLAYER" cly)<br />     (setq *error* err_old)<br />   ) ;_ end of defun<br />   (setq        err_old        *error*<br />         *error*        err_new<br />   ) ;_ end of setq<br />   (set_ini)<br />   (setq xdgch 290000);相对高程<br />   (setq dmx (car (nentsel "请选择断面:")))<br />   (command "_.ucsicon" "off")<br />   (command "_.ucs" "ob" dmx)<br />   (setq        sp     (cdr (assoc 10 (entget dmx)))<br />         ep     (cdr (assoc 11 (entget dmx)))<br />         sp_ucs (trans sp 0 1)<br />         ep_ucs (trans ep 0 1)<br />         ang    (angle sp_ucs ep_ucs)<br />   ) ;_ end of setq<br />   (if (and (> ang (/ pi 2)) (< ang (* pi 1.5)))<br />     (setq ang1 (* pi 1.5))<br />     (setq ang1 (/ pi 2))<br />   ) ;_ end of if<br />   (setq        ss1 (ssget "f"<br />                    (list sp_ucs ep_ucs)<br />                    '((8 . "Dx-dgx") (0 . "LWPOLYLINE"))<br />             ) ;_ end of ssget<br />   ) ;_ end of setq<br />   (if (/= ss1 nil)<br />     (progn (command "qaflags" 1) (command "_.explode" ss1 ""))<br />   ) ;_ end of if<br />   (setq        ss2 (ssget "f"<br />                    (list sp_ucs ep_ucs)<br />                    '((8 . "Dx-dgx") (0 . "line"))<br />             ) ;_ end of ssget<br />   ) ;_ end of setq<br />   (setq        sslen           (sslength ss2)<br />         sslst           nil<br />         n           0<br />         inters_p_l nil<br />   ) ;_ end of setq<br />   (while (< n sslen)<br />     (setq ent (ssname ss2 n))<br />     (setq sp1 (cdr (assoc 10 (entget ent)))<br />           ep1 (cdr (assoc 11 (entget ent)))<br />           sp2 (list (car sp1) (cadr sp1) (caddr sp))<br />           ep2 (list (car ep1) (cadr ep1) (caddr ep))<br />     ) ;_ end of setq<br />     (setq inters_p (inters sp ep sp2 ep2))<br />     (setq inters_p_l<br />            (cons (list inters_p (caddr sp1)) inters_p_l) ;_ end of cons<br />     ) ;_ end of setq<br />     (setq n (1+ n))<br />   ) ;_ end of while<br />   (setq        ll     (length inters_p_l)<br />         n      1<br />         sp_ucs (trans sp 0 1)<br />         ep_ucs (trans ep 0 1)<br />   ) ;_ end of setq<br />   (setq        pt_0   (trans (car (nth 0 inters_p_l)) 0 1)<br />         h      (car (cdr (nth 0 inters_p_l)))<br />         pt_0_t (polar pt_0 ang1 (- h xdgch))<br />         gro1   nil<br />         gro2   nil<br />   ) ;_ end of setq<br />   (command "_.line" pt_0 pt_0_t "")<br />   (setq gro1 (cons (entlast) gro))<br />   (while (< n ll)<br />     (setq pt_n         (trans (car (nth n inters_p_l)) 0 1)<br />           h         (car (cdr (nth n inters_p_l)))<br />           pt_n_t (polar pt_n ang1 (- h xdgch))<br />     ) ;_ end of setq<br />     (command "_.line" pt_n pt_n_t "")<br />     (setq gro1 (cons (entlast) gro1))<br />     (command "_.line" pt_0_t pt_n_t "")<br />     (setq gro2 (cons (entlast) gro2))<br />     (setq pt_0_t pt_n_t)<br />     (setq n (1+ n))<br />   ) ;_ end of while<br />   (command "_.line" pt_0 pt_n "")<br />   (setq        pt_0 (trans pt_0 1 0)<br />         pt_n (trans pt_n 1 0)<br />   ) ;_ end of setq<br />   (setq gro2 (cons (entlast) gro2))<br />   (command "_.ucs" "p")<br />   (command "_.ucsicon" "on")<br />   (dm:makgrp gro1 "In use by DuanMian")<br />   (dm:makgrp gro2 "In use by DuanMian")<br />   (setq<br />     pt3        (getpoint "\n点取断面图左下角点位置(不移动断面图直接回车):") ;_ end of getpoint<br />   ) ;_ end of setq<br />   (if (/= nil pt3)<br />     (progn (setq pt4  (polar pt3 0 xdgch)<br />                  pt_0 (trans pt_0 0 1)<br />                  pt_n (trans pt_n 0 1)<br />            ) ;_ end of setq<br />            (if (< (car pt_0) (car pt_n))<br />              (dm:align (append gro1 gro2) pt_0 pt3 pt_n pt4)<br />              (dm:align (append gro1 gro2) pt_n pt3 pt_0 pt4)<br />            ) ;_ end of if<br />     ) ;_ end of progn<br />   ) ;_ end of if<br />   (command "qaflags" 0)<br />   (set_close)<br />   (gc)<br />   (princ)<br /> ) ;_ end of defun<br /> <br /> (defun dm:makgrp (LST DESC / NAM EN LST GDICT GDATA)<br />   (setq<br />     NAM        (strcat "DuanMian" (substr (rtos (getvar "CDATE") 2 8) 10)) ;_ end of strcat<br />   ) ;_ end of setq<br />   (command "_.-group" "_create" NAM DESC)<br />   (foreach EN LST (command EN))<br />   (command "")<br />   (setq        GDICT (dictsearch (namedobjdict) "ACAD_GROUP")<br />         GDATA (dictsearch (cdr (assoc -1 GDICT)) NAM)<br />         GDATA (subst (cons 70 1) (assoc 70 GDATA) GDATA)<br />   ) ;_ end of setq<br />   (dictrename (cdr (assoc -1 GDICT)) NAM "*A")<br />   (entmod GDATA)<br /> ) ;_ end of defun<br /> <br /> <br /> (defun dm:align        (gro f_pt1 f_pt2 f_pt3 f_pt4 / en f_test f_osmode)<br />   (setq f_osmode -1)<br />   (if (not<br />         (or (null f_pt1) (null f_pt2) (null f_pt3) (null f_pt4)) ;_ end of or<br />       ) ;_ end of not<br />     (progn (if (< (getvar "osmode") 16384)<br />              (progn (setq f_osmode (getvar "osmode"))<br />                     (setvar "osmode" (+ f_osmode 16384))<br />              ) ;_ end of progn<br />            ) ;_ end of if<br />            (command "ucs" "z" f_pt2 f_pt4)<br />            (command "rotate")<br />            (foreach EN gro (command EN))<br />            (command "" f_pt1 "r" f_pt1 f_pt3 "0") ;_ end of command<br />            (command "ucs" "p")<br />            (command "move" "P" "" f_pt1 f_pt2)<br />            (if (/= f_osmode -1)<br />              (setvar "osmode" f_osmode)<br />            ) ;_ end of if<br />     ) ;_ end of progn<br />   ) ;_ end of if<br />   (princ)<br /> ) ;_ end of defun<br />

ywp7103

我有一个小程序,发给你试试

jhw

我也想要，邮箱：qdzhj@yeah.net,多谢！

lishj_1982

to2楼楼主，我也需要一个，可以发个给我看看不？
lishj_1982@yeah.net

MUYIY

谢谢

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！！

kmliro_2017

谢谢分享！！！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

感谢分享！！！！