[LISP程序]：一个立面图标高的程序

ahill

下不了啊。。郁闷。。好久没来。。什么都不够了。。

gzylxp

我也关注一下，但现还不能下，回家后好好研究 ,我现在没钱啊，不能下啊

whiteon

字太大了，如何能缩小一点。

paxsy

我也关注一下，下载研究研究

覃海洋

如果能过改字高就好了
就不用那样麻烦了`

hsb-hy

建议：
   如果能加入比例选项就好了！提示比例1：，让使用者输入比例，这样就很好！

li809

能改为可选字体的吗

wuy

下了，谢谢楼主

zqb05

为什么不能下

tboy2080

这个东西还蛮使用，谢谢楼主

xunzhao123

2. [php]
   
3. ;|
   
4. LPMBG.lsp 立剖面标高
   
5. * C:LPMBG
   
6. -- XYP@bsedi.com
   
7. 2004.11.14
   
8. |;
   
9. (prompt "\n\r      加载立剖面标高程序。")
   
10. ;;;-------------------------------------------
    
11. ;;;主程序
    
12. (DEFUN C:LPMBG (/ pt1 x x1 dy)
    
13.   (CMDLA0)
    
14.   (vl-cmdf ".undo" "BE")
    
15.   (MKLA "biaogao" 3)  
    
16.   (setq        txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))
    
17.   (while (or (= txt5 "5")(NULL PT0))(@jidian)
    
18.     (setq txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))
    
19.     )
    
20.   (while (or (= txt5 "4")(NULL SC))(@setbl1)
    
21.     (setq txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))
    
22.     )
    
23.   (if (= txt5 "3")(@sec))
    
24.   (if (or (= txt5"1")(= txt5"2"))
    
25.     (progn
    
26.       (while
    
27.     (SETQ pt1 (getpoint pt0 "\n\t标高位置点<退出> : "))
    
28.     (setq x (- (cadr pt1) (cadr pt0))
    
29.           x1 (* (/ x 1000) (GETVAR "DIMLFAC"))
    
30.           dy (rtos x1 2 3)
    
31.            )
    
32.     (if (= txt5 "2")(@bgleft))
    
33.     (if (= txt5 "1")(@bgright))
    
34.     )))
    
35.   (vl-cmdf ".undo" "E")
    
36.   (CMDLA1)
    
37. )
    
38. ;;;-------------------------------------------
    
39. ;;;子程序
    
40. ;;;±0.000基点
    
41. (defun @jidian()
    
42.   (WHILE (NOT (SETQ pt0 (getpoint "\n\t确定±0.000标高点 : "))))
    
43.   )
    
44. ;;;左标高
    
45. (defun @bgleft()
    
46.   (if        (= X 0)
    
47.       (command "INSERT" "BG&#8722;L"pt1SCSC"0""±0.000")(command"INSERT""BG&#8722;L"pt1SCSC"0""±0.000")(command"INSERT""BG-L" pt1 SC SC "0" dy)
    
48.     )
    
49.   )
    
50. ;;;右标高
    
51. (defun @bgright()
    
52.   (if        (= X 0)
    
53.       (command "INSERT" "BG&#8722;R"pt1SCSC"0""±0.000")(command"INSERT""BG&#8722;R"pt1SCSC"0""±0.000")(command"INSERT""BG-R" pt1 SC SC "0" dy)
    
54.     )
    
55.   )
    
56. ;;;剖面标高
    
57. (defun @sec()
    
58.   (setq H-ceng (ureal 1 "" "层高(m)" h-ceng))
    
59.   (setq n-ceng (ureal 1 "" "层数" n-ceng))
    
60.   (setvar "osmode"0)
    
61.   (command "ucs" "o" pt0)
    
62.   (setq y0 0 n 0 pt0 (list 0 0))
    
63.   (while (< n (+ 1 n-ceng))
    
64.     (setq y (* (/ y0 1000.0) (GETVAR "DIMLFAC"))
    
65.           y (rtos y 2 3)
    
66.           )
    
67.     (if        (= y0 0)
    
68.       (command "INSERT" "BG&#8722;R"pt0SCSC"0""±0.000")(command"INSERT""BG&#8722;R"pt0SCSC"0""±0.000")(command"INSERT""BG-R" pt0 SC SC "0" y)
    
69.     )
    
70.     (setq n (+ 1 n))
    
71.     (setq y0 (* n 1000.0 h-ceng))
    
72.     (setq pt0 (list 0 y0))
    
73.   )
    
74.   (command "ucs" "")
    
75.   ;(exit)
    
76. )
    
77. ;;;-------------------------------------------
    
78. ;;;通用子程序
    
79. ;;;
    
80. (defun CMDLA0 ()
    
81.   (setq cmdech (getvar "CMDECHO"))
    
82.   (setq oom (getvar "orthomode"))
    
83.   (setq osm (getvar "osmode"))
    
84.   (SETQ LA (getvar "clayer"))
    
85.   (setq rmode (getvar "regenmode"))
    
86.   (setq pw (getvar "plinewid"))
    
87.   (setvar "regenmode" 0)
    
88.   (setvar "CMDECHO" 0)
    
89.   (princ)
    
90. )
    
91. 
    
92. ;;;
    
93. (defun CMDLA1 ()
    
94.   (setvar "CMDECHO" cmdech)
    
95.   (setvar "orthomode" oom)
    
96.   (setvar "osmode" osm)
    
97.   (setvar "clayer" LA)
    
98.   (setvar "regenmode" rmode)
    
99.   (setvar "plinewid" pw)
    
100.   (princ)
     
101. )
     
102. 
     
103. ;;;图层输入格式化
     
104. (Defun MKLA (a b)
     
105.   (If (= (Tblsearch "layer" a) nil)
     
106.     (Command "layer" "m" a "c" b a "")
     
107.     (Command "layer" "t" a "s" a "c" b a "")
     
108.   )
     
109. )
     
110. 
     
111. ;;;
     
112. (defun @ukword (bit kwd msg def / inp)
     
113.   (if (and def (/= def ""))
     
114.     (setq msg (strcat "\n" msg "<" def ">:")
     
115.           bit (* 2 (fix (/ bit 2)))
     
116.     )
     
117.     (setq msg (strcat "\n" msg ":"))
     
118.   )
     
119.   (initget bit kwd)
     
120.   (setq inp (getkword msg))
     
121.   (if inp
     
122.     inp
     
123.     def
     
124.   )
     
125. )
     
126. ;;;数字格式化输入
     
127. (defun @ureal (bit kwd msg def / inp)
     
128.   (if def
     
129.     (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
     
130.           bit (* 2 (fix (/ bit 2)))
     
131.     )
     
132.     (setq msg (strcat "\n" msg ": "))
     
133.   )
     
134.   (initget bit kwd)
     
135.   (setq inp (getreal msg))
     
136.   (if inp
     
137.     inp
     
138.     def
     
139.   )
     
140. )
     
141. 
     
142. ;;;出图比例
     
143. (defun @setbl1 ()
     
144.   (setq bl (@ureal 1 "" "\n输入出图比例1 : " bl)        SC (/ bl 100))
     
145.   (command "modemacro" (strcat "XCAD BY XYP." " 当前出图比例 1:" (rtos bl 2 1)))
     
146. )
     
147. 
     
148. ;;;
     
149. (DEFUN PXYP (TXT1)
     
150.   (SETQ        TXT1 (STRCAT "\n\r      程序命令: " TXT1 "      -- xyp@bsedi.com"))
     
151.   (PRINC TXT1)
     
152.   (Princ)
     
153. )
     
154. 
     
155. ;;;
     
156. (pxyp "LPMBG      (立剖面标高)")
     
157. (princ)
     
158. ;;;-------------------------------------------
     
159. ;;;END
     
160. [/php]

[php]<br /> ;|<br /> LPMBG.lsp 立剖面标高<br /> * C:LPMBG<br /> -- XYP@bsedi.com<br /> 2004.11.14<br /> |;<br /> (prompt "\n\r      加载立剖面标高程序。")<br /> ;;;-------------------------------------------<br /> ;;;主程序<br /> (DEFUN C:LPMBG (/ pt1 x x1 dy)<br />   (CMDLA0)<br />   (vl-cmdf ".undo" "BE")<br />   (MKLA "biaogao" 3)  <br />   (setq        txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))<br />   (while (or (= txt5 "5")(NULL PT0))(@jidian)<br />     (setq txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))<br />     )<br />   (while (or (= txt5 "4")(NULL SC))(@setbl1)<br />     (setq txt5 (@ukword 1 "1 2 3 4 5" "\n请选择形式：1-右标高/2-左标高/3-剖面标高/4-设出图比例/5-设±0.000基点" txt5))<br />     )<br />   (if (= txt5 "3")(@sec))<br />   (if (or (= txt5"1")(= txt5"2"))<br />     (progn<br />       (while<br />     (SETQ pt1 (getpoint pt0 "\n\t标高位置点<退出> : "))<br />     (setq x (- (cadr pt1) (cadr pt0))<br />           x1 (* (/ x 1000) (GETVAR "DIMLFAC"))<br />           dy (rtos x1 2 3)<br />            )<br />     (if (= txt5 "2")(@bgleft))<br />     (if (= txt5 "1")(@bgright))<br />     )))<br />   (vl-cmdf ".undo" "E")<br />   (CMDLA1)<br /> )<br /> ;;;-------------------------------------------<br /> ;;;子程序<br /> ;;;±0.000基点<br /> (defun @jidian()<br />   (WHILE (NOT (SETQ pt0 (getpoint "\n\t确定±0.000标高点 : "))))<br />   )<br /> ;;;左标高<br /> (defun @bgleft()<br />   (if        (= X 0)<br />       (command "INSERT" "BG&#8722;L"pt1SCSC"0""±0.000")(command"INSERT""BG&#8722;L"pt1SCSC"0""±0.000")(command"INSERT""BG-L" pt1 SC SC "0" dy)<br />     )<br />   )<br /> ;;;右标高<br /> (defun @bgright()<br />   (if        (= X 0)<br />       (command "INSERT" "BG&#8722;R"pt1SCSC"0""±0.000")(command"INSERT""BG&#8722;R"pt1SCSC"0""±0.000")(command"INSERT""BG-R" pt1 SC SC "0" dy)<br />     )<br />   )<br /> ;;;剖面标高<br /> (defun @sec()<br />   (setq H-ceng (ureal 1 "" "层高(m)" h-ceng))<br />   (setq n-ceng (ureal 1 "" "层数" n-ceng))<br />   (setvar "osmode"0)<br />   (command "ucs" "o" pt0)<br />   (setq y0 0 n 0 pt0 (list 0 0))<br />   (while (< n (+ 1 n-ceng))<br />     (setq y (* (/ y0 1000.0) (GETVAR "DIMLFAC"))<br />           y (rtos y 2 3)<br />           )<br />     (if        (= y0 0)<br />       (command "INSERT" "BG&#8722;R"pt0SCSC"0""±0.000")(command"INSERT""BG&#8722;R"pt0SCSC"0""±0.000")(command"INSERT""BG-R" pt0 SC SC "0" y)<br />     )<br />     (setq n (+ 1 n))<br />     (setq y0 (* n 1000.0 h-ceng))<br />     (setq pt0 (list 0 y0))<br />   )<br />   (command "ucs" "")<br />   ;(exit)<br /> )<br /> ;;;-------------------------------------------<br /> ;;;通用子程序<br /> ;;;<br /> (defun CMDLA0 ()<br />   (setq cmdech (getvar "CMDECHO"))<br />   (setq oom (getvar "orthomode"))<br />   (setq osm (getvar "osmode"))<br />   (SETQ LA (getvar "clayer"))<br />   (setq rmode (getvar "regenmode"))<br />   (setq pw (getvar "plinewid"))<br />   (setvar "regenmode" 0)<br />   (setvar "CMDECHO" 0)<br />   (princ)<br /> )<br /> <br /> ;;;<br /> (defun CMDLA1 ()<br />   (setvar "CMDECHO" cmdech)<br />   (setvar "orthomode" oom)<br />   (setvar "osmode" osm)<br />   (setvar "clayer" LA)<br />   (setvar "regenmode" rmode)<br />   (setvar "plinewid" pw)<br />   (princ)<br /> )<br /> <br /> ;;;图层输入格式化<br /> (Defun MKLA (a b)<br />   (If (= (Tblsearch "layer" a) nil)<br />     (Command "layer" "m" a "c" b a "")<br />     (Command "layer" "t" a "s" a "c" b a "")<br />   )<br /> )<br /> <br /> ;;;<br /> (defun @ukword (bit kwd msg def / inp)<br />   (if (and def (/= def ""))<br />     (setq msg (strcat "\n" msg "<" def ">:")<br />           bit (* 2 (fix (/ bit 2)))<br />     )<br />     (setq msg (strcat "\n" msg ":"))<br />   )<br />   (initget bit kwd)<br />   (setq inp (getkword msg))<br />   (if inp<br />     inp<br />     def<br />   )<br /> )<br /> ;;;数字格式化输入<br /> (defun @ureal (bit kwd msg def / inp)<br />   (if def<br />     (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")<br />           bit (* 2 (fix (/ bit 2)))<br />     )<br />     (setq msg (strcat "\n" msg ": "))<br />   )<br />   (initget bit kwd)<br />   (setq inp (getreal msg))<br />   (if inp<br />     inp<br />     def<br />   )<br /> )<br /> <br /> ;;;出图比例<br /> (defun @setbl1 ()<br />   (setq bl (@ureal 1 "" "\n输入出图比例1 : " bl)        SC (/ bl 100))<br />   (command "modemacro" (strcat "XCAD BY XYP." " 当前出图比例 1:" (rtos bl 2 1)))<br /> )<br /> <br /> ;;;<br /> (DEFUN PXYP (TXT1)<br />   (SETQ        TXT1 (STRCAT "\n\r      程序命令: " TXT1 "      -- xyp@bsedi.com"))<br />   (PRINC TXT1)<br />   (Princ)<br /> )<br /> <br /> ;;;<br /> (pxyp "LPMBG      (立剖面标高)")<br /> (princ)<br /> ;;;-------------------------------------------<br /> ;;;END<br /> [/php]