外国 lisp 实例，求助修改

MRHDF

原文： ;; Save System Varibles
(defun SSV (savelist)
(mapcar
'(lambda (sysvar)
(list sysvar (getvar sysvar))
)
savelist)
)
(setq lista '("blipmode" "cecolor" "clayer" "cmdecho"
"orthomode" "osmode" "snapmode")) ;; Reset System Varibles
(defun RSV (savelist)
(mapcar
'(lambda (sysvar)
(setvar (car sysvar)(cadr sysvar))
(car sysvar)
)
savelist)
) ;; Error handler
(defun err ()
(command ".undo" "mark")
(setq olderr *error*)
(defun *error* (errstr)
(print errstr)(princ)
(setq lista (RSV lista))
(setq *error* olderr)
(princ)
)
(setq lista (SSV lista))
(setvar "blipmode" 0)
(setvar "cmdecho" 0)
(setvar "orthomode" 0)
(setvar "snapmode" 0)
) (defun reset ()
(setq lista (RSV lista))
(setq *error* olderr)
) ;; GetMidpoint routine
(defun gm ( / lst lpt1 lpt2 mx my midp )
(setq lst (entget (entlast)))
(setq lpt1 (cdr (assoc 10 lst)))
(setq lpt2 (cdr (assoc 11 lst)))
(setq lpt1 (car (list lpt1 lpt2)))
(setq lpt2 (cadr (list lpt1 lpt2)))
(setq mx (* (+ (nth 0 lpt1) (nth 0 lpt2)) 0.5))
(setq my (* (+ (nth 1 lpt1) (nth 1 lpt2)) 0.5))
(setq midp (list mx my))
) ;; Main Defun
(defun win ( / cl ce pb ap line1 pt#1 pt#2 pt#3 pt#4 pm#1 pm#2 pm#3 pm#4
ang1 ang2 wan1 wan2 jm#1 jm#2 mp#1 mp#2 i# mdst fstm nxtm
ml#1 gp#1 gp#2 cla tla l70) (setq cl (getvar "clayer")
ce (getvar "cecolor")
) ;; Save variables for next time
(if (not wsz) (setq wsz *wsz) (setq *wsz wsz))
(if (not mlx) (setq mlx *mlx) (setq *mlx mlx))
(if (not mly) (setq mly *mly) (setq *mly mly))
(if (not lit) (setq lit *lit) (setq *lit lit)) ;; Find the wall points (setq line1 (entsel "\nSelect first wall line to be opened: ")
pt#1 (nth 1 line1))
(setvar "osmode" 128)
(setq pt#2 (getpoint pt#1 "\nSelect opposite face to be opened: ")
ang1 (angle pt#1 pt#2)
ang2 (angle pt#2 pt#1))
(setvar "osmode" 0)
(cond
((= lmr "Left") (setq wan1 (+ ang1 1.5708)
wan2 (+ ang2 1.5708)))
((= lmr "Right") (setq wan1 (+ ang1 4.71239)
wan2 (+ ang2 4.71239)))
((= lmr "Middle") (setq wang (+ ang1 1.5708)
pt#1 (polar pt#1 wang (* wsz 0.5))
pt#2 (polar pt#2 wang (* wsz 0.5))
wan1 (+ ang1 4.71239)
wan2 (+ ang2 4.71239)))
)
(setq pt#3 (polar pt#1 wan1 wsz)
pt#4 (polar pt#2 wan1 wsz)
mp#1 (polar pt#1 wan1 (* wsz 0.5))
mp#2 (polar pt#2 wan1 (* wsz 0.5))
) ;; Cut the opening
(setq l1_list (entget (car line1)))
(setvar "clayer" (cdr (assoc 8 l1_list)))
(cond
((setq c_list (assoc 62 l1_list))
(setq color (cdr cr_list))
(command ".color" color)
)
) ;; Check for locked layer
(setq cla (getvar "clayer")
tla (tblsearch "layer" cla)
l70 (cdr (assoc 70 tla))
)
(if (= l70 68)
(command "layer" "unlock" cla "")
) (command ".break" pt#1 pt#3 ".break" pt#2 pt#4)
(setvar "osmode" 512)
(command ".line" pt#1 pt#2 "")
(setq jm#1 (gm))
(command ".line" pt#3 pt#4 "")
(setq jm#2 (gm)) (if (= l70 68)
(command "layer" "lock" cla "")
)
(setvar "clayer" cl)
(setvar "cecolor" ce)
(setvar "osmode" 0) ;; Build the mullions
(setq pm#1 (polar jm#1 ang1 (* mly 0.5))
pm#2 (polar pm#1 wan1 mlx)
pm#3 (polar pm#2 ang2 mly)
pm#4 (polar pm#3 wan2 mlx)
jm#1 (polar pm#2 ang2 (* mly 0.5))
)
(command ".pline" pm#1 pm#2 pm#3 pm#4 "close")
(setq ml#1 (entlast)) ;; Build the rest of the mullions & glass
(setq i# 0
mdst (/ (- wsz mlx) lit)
fstm (polar jm#1 wan2 (* mlx 0.5))
nxtm (polar fstm wan1 mdst)
gp#1 (polar fstm wan1 (* mlx 0.5))
gp#2 (polar nxtm wan2 (* mlx 0.5))
) (While (< i# lit)
(command "copy" "single" ml#1 fstm nxtm )
(setq ml#1 (entlast))
(command "line" gp#1 gp#2 "")
(setq fstm nxtm
nxtm (polar fstm wan1 mdst)
gp#1 (polar fstm wan1 (* mlx 0.5))
gp#2 (polar nxtm wan2 (* mlx 0.5)) )
(Setq i# (1+ i#))
) ) ;; --Command line functions-- (defun c:win ( / aslu lmr wsz lit mlx mly ) (err)
(initget "Left Middle Right")
(setq aslu (getvar "lunits")
lmr (getkword "\nInsertion point Left, Middle or <Right>: "))
(if (= lmr nil)
(setq lmr "Right")
) ;; Window size
(if (not *wsz) (setq *wsz 48.0))
(princ "\nEnter size of window opening <")
(princ (rtos *wsz aslu))
(setq wsz (getdist ">: ")) ;; Number of Windows
(if (not *lit) (setq *lit 1))
(princ "\nEnter number of window lites <")
(princ *lit)
(initget 6)
(setq lit (getint ">: ")) ;; Mullion size
(if (not *mlx) (setq *mlx 2.0))
(if (not *mly) (setq *mly 4.0))
(princ "\nEnter length of mullion <")
(princ (rtos *mlx aslu))
(setq mlx (getdist ">: "))
(princ "\nEnter size of window opening <")
(princ (rtos *mly aslu))
(setq mly (getdist ">: "))
(win)
(reset)
(princ)
) ；原文结束 希望绘制窗子的pt#1时候能够确定在某一个具体的位置，比如在距离这条线与其他线的焦点后者这条线的端点有n个单位远的位置。

MRHDF

图片在这里 请高手指点。 更多外国lisp 欢迎交流。 电邮或雅虎通 mrhdf@yahoo.com.cn

MRHDF

xstlf

;;;自编的中点插窗，大家分享。再帮忙改进一下。 ;;;中点插窗，由此生成的窗为非块实体，可以直接拉伸
(defun c:CC (/ angd angb cmdech osm la rmode pt1 pt2 ss1 ss2 wall1
wall2 ang dist pt3 pt4 pt5 pt6 lt3 lt4 lt5 lt6)
(setq angd (getvar "angdir"))
(setq angb (getvar "angbase"))
(setq cmdech (getvar "CMDECHO"))
(setq osm (getvar "osmode"))
(SETQ LA (getvar "clayer"))
(setq rmode (getvar "regenmode"))
(setvar "regenmode" 1)
(setvar "CMDECHO" 0)
(setvar "angdir" 0)
(setvar "angbase" 0)
(setq no12 (@User2 1 "" "\n输入窗宽度：" no12))
(command "-layer" "m" "门窗" "c" "4" "门窗" "l" "continuous" "" "")
(setvar "clayer" "墙体")
(setvar "osmode" 34)
(command "-layer" "f" "轴线" "")
(while
(setq pt1 (getpoint "\n输入第一条墙线的中点："))
(setvar "osmode" 160)
(setq pt2 (getpoint pt1 "\n输入第二条墙线的插入点："))
(command "-layer" "t" "轴线" "")
(setvar "osmode" osm)
(setvar "clayer" LA)
(command "_.undo" "be")
(setvar "osmode" 0)
(setq ss1 (ssget pt1)
ss2 (ssget pt2)
)
(setq wall1 (ssname ss1 0)
wall2 (ssname ss2 0)
)
(setq ang (angle pt1 pt2)
dist1 (distance pt1 pt2)
)
(setq pt3 (polar pt1 (+ ang (/ pi 2)) (/ no12 2))
pt4 (polar pt2 (+ ang (/ pi 2)) (/ no12 2))
pt5 (polar pt1 (- ang (/ pi 2)) (/ no12 2))
pt6 (polar pt2 (- ang (/ pi 2)) (/ no12 2))
)
(setq lt3 (polar pt3 ang (- (/ dist1 2) 30))
lt4 (polar pt4 ang (- 30 (/ dist1 2)))
lt5 (polar pt5 ang (- (/ dist1 2) 30))
lt6 (polar pt6 ang (- 30 (/ dist1 2)))
)
(setvar "clayer" "墙体")
(command "_.line" pt3 pt4 "")
(command "_.line" pt5 pt6 "")
(command "_.break" wall1 pt3 pt5)
(command "_.break" wall2 pt4 pt6)
(setvar "clayer" "门窗")
(command "_.line" pt3 pt5 "")
(command "_.line" pt4 pt6 "")
(command "_.line" lt3 lt5 "")
(command "_.line" lt4 lt6 "")
(command "-layer" "f" "轴线" "")
(setvar "osmode" 34)
(command "_.undo" "e")
)
(command "-layer" "t" "轴线" "")
(princ)
(setvar "angdir" angd)
(setvar "angbase" angb)
(setvar "CMDECHO" cmdech)
(setvar "osmode" osm)
(setvar "clayer" LA)
(setvar "regenmode" rmode)
(princ "\n76067133@qq.com")
)
(defun @User2 (bit kwd msg def / inp)
(if def
(setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
bit (* 2 (fix (/ bit 2))))
(setq msg (strcat "\n" msg ": ")))
(initget bit kwd)
(setq inp (getreal msg))
(if inp inp def)
)

MRHDF

大侠你这个不错       


我也想自己建立门窗的lisp,正在学习中。


我用你的cc的时候被拒绝         [U]utoCAD 变量设置被拒绝: "clayer" "墙体"[/U]


最好绘制图元时候可以创建图层，如果不行创建到但前途层也可以。


                                         (COMMAND "LAYER" "M" "WINDOW" "C" "YELLOW" "" "")


       


这句可以创建一个新的图层

xstlf

(setvar "clayer" "墙体")
楼上的你把这儿的“墙体”改成你自己的墙体图层就可，"轴线" 改成你自己的图中轴线所对应的图层就行。其他的不用改。

xyp1964

3. ;;;自编的中点插窗，大家分享。再帮忙改进一下。
4. ;;;中点插窗，由此生成的窗为非块实体，可以直接拉伸
5. (defun c:win (/       angd   angb   cmdech       osm   la       rmode pt1
6.            pt2     ss1   ss2     wall1 wall2 ang   dist   pt3     pt4
7.            pt5     pt6   lt3     lt4     lt5     lt6
8.          )
9.    (setq angd (getvar "angdir"))
10.    (setq angb (getvar "angbase"))
11.    (setq cmdech (getvar "CMDECHO"))
12.    (setq osm (getvar "osmode"))
13.    (SETQ LA (getvar "clayer"))
14.    (setq rmode (getvar "regenmode"))
15.    (setvar "regenmode" 1)
16.    (setvar "CMDECHO" 0)
17.    (setvar "angdir" 0)
18.    (setvar "angbase" 0)
19.    (setq no12 (@User2 1 "" "\n输入窗宽度" no12))
20.    ;(command "-layer" "m"  "门窗" "c" "4" "门窗" "l" "continuous" "" "")
21.    (mkla"门窗"4)
22.    (mkla"墙体"2)
23.    (mkla"轴线"1)
24.    ;(setvar "clayer" "墙体")
25.    (setvar "osmode" 34)
26.    (command "-layer" "f" "轴线" "")
27.    (while
28.        (setq pt1 (getpoint "\n输入第一条墙线的中点："))
29.          (setvar "osmode" 160)
30.          (setq pt2 (getpoint pt1 "\n输入第二条墙线的插入点："))
31.          (command "-layer" "t" "轴线" "")
32.          (setvar "osmode" osm)
33.          (setvar "clayer" LA)
34.          (command "_.undo" "be")
35.          (setvar "osmode" 0)
36.          (setq ss1 (ssget pt1)
37.        ss2 (ssget pt2)
38.          )
39.          (setq wall1 (ssname ss1 0)
40.        wall2 (ssname ss2 0)
41.          )
42.          (setq ang   (angle pt1 pt2)
43.        dist1 (distance pt1 pt2)
44.          )
45.          (setq pt3 (polar pt1 (+ ang (/ pi 2)) (/ no12 2))
46.        pt4 (polar pt2 (+ ang (/ pi 2)) (/ no12 2))
47.        pt5 (polar pt1 (- ang (/ pi 2)) (/ no12 2))
48.        pt6 (polar pt2 (- ang (/ pi 2)) (/ no12 2))
49.          )
50.          (setq lt3 (polar pt3 ang (- (/ dist1 2) 30))
51.        lt4 (polar pt4 ang (- 30 (/ dist1 2)))
52.        lt5 (polar pt5 ang (- (/ dist1 2) 30))
53.        lt6 (polar pt6 ang (- 30 (/ dist1 2)))
54.          )
55.          (setvar "clayer" "墙体")
56.          (command "_.line" pt3 pt4 "")
57.          (command "_.line" pt5 pt6 "")
58.          (command "_.break" wall1 pt3 pt5)
59.          (command "_.break" wall2 pt4 pt6)
60.          (setvar "clayer" "门窗")
61.          (command "_.line" pt3 pt5 "")
62.          (command "_.line" pt4 pt6 "")
63.          (command "_.line" lt3 lt5 "")
64.          (command "_.line" lt4 lt6 "")
65.          (command "-layer" "f" "轴线" "")
66.          (setvar "osmode" 34)
67.          (command "_.undo" "e")
68.    )
69.    (command "-layer" "t" "轴线" "")
70.    (princ)
71.    (setvar "angdir" angd)
72.    (setvar "angbase" angb)
73.    (setvar "CMDECHO" cmdech)
74.    (setvar "osmode" osm)
75.    (setvar "clayer" LA)
76.    (setvar "regenmode" rmode)
77.    ;(princ "\n76067133@qq.com")
78. )
79. (defun @User2 (bit kwd msg def / inp)
80.    (if def
81.        (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
82.      bit (* 2 (fix (/ bit 2)))
83.        )
84.        (setq msg (strcat "\n" msg ": "))
85.    )
86.    (initget bit kwd)
87.    (setq inp (getreal msg))
88.    (if inp
89.        inp
90.        def
91.    )
92. )
93. (defun mkla (name color)
94.    (If (= (Tblsearch "layer" name) nil)
95.        (Command "layer" "m" name "c" color name "")
96.        (Command "layer" "t" name "s" name "c" color name "")
97.    )
98. )

;;;自编的中点插窗，大家分享。再帮忙改进一下。 ;;;中点插窗，由此生成的窗为非块实体，可以直接拉伸 (defun c:win (/       angd   angb   cmdech       osm   la       rmode pt1            pt2     ss1   ss2     wall1 wall2 ang   dist   pt3     pt4            pt5     pt6   lt3     lt4     lt5     lt6          )    (setq angd (getvar "angdir"))    (setq angb (getvar "angbase"))    (setq cmdech (getvar "CMDECHO"))    (setq osm (getvar "osmode"))    (SETQ LA (getvar "clayer"))    (setq rmode (getvar "regenmode"))    (setvar "regenmode" 1)    (setvar "CMDECHO" 0)    (setvar "angdir" 0)    (setvar "angbase" 0)    (setq no12 (@User2 1 "" "\n输入窗宽度" no12))    ;(command "-layer" "m"  "门窗" "c" "4" "门窗" "l" "continuous" "" "")    (mkla"门窗"4)    (mkla"墙体"2)    (mkla"轴线"1)    ;(setvar "clayer" "墙体")    (setvar "osmode" 34)    (command "-layer" "f" "轴线" "")    (while        (setq pt1 (getpoint "\n输入第一条墙线的中点："))          (setvar "osmode" 160)          (setq pt2 (getpoint pt1 "\n输入第二条墙线的插入点："))          (command "-layer" "t" "轴线" "")          (setvar "osmode" osm)          (setvar "clayer" LA)          (command "_.undo" "be")          (setvar "osmode" 0)          (setq ss1 (ssget pt1)        ss2 (ssget pt2)          )          (setq wall1 (ssname ss1 0)        wall2 (ssname ss2 0)          )          (setq ang   (angle pt1 pt2)        dist1 (distance pt1 pt2)          )          (setq pt3 (polar pt1 (+ ang (/ pi 2)) (/ no12 2))        pt4 (polar pt2 (+ ang (/ pi 2)) (/ no12 2))        pt5 (polar pt1 (- ang (/ pi 2)) (/ no12 2))        pt6 (polar pt2 (- ang (/ pi 2)) (/ no12 2))          )          (setq lt3 (polar pt3 ang (- (/ dist1 2) 30))        lt4 (polar pt4 ang (- 30 (/ dist1 2)))        lt5 (polar pt5 ang (- (/ dist1 2) 30))        lt6 (polar pt6 ang (- 30 (/ dist1 2)))          )          (setvar "clayer" "墙体")          (command "_.line" pt3 pt4 "")          (command "_.line" pt5 pt6 "")          (command "_.break" wall1 pt3 pt5)          (command "_.break" wall2 pt4 pt6)          (setvar "clayer" "门窗")          (command "_.line" pt3 pt5 "")          (command "_.line" pt4 pt6 "")          (command "_.line" lt3 lt5 "")          (command "_.line" lt4 lt6 "")          (command "-layer" "f" "轴线" "")          (setvar "osmode" 34)          (command "_.undo" "e")    )    (command "-layer" "t" "轴线" "")    (princ)    (setvar "angdir" angd)    (setvar "angbase" angb)    (setvar "CMDECHO" cmdech)    (setvar "osmode" osm)    (setvar "clayer" LA)    (setvar "regenmode" rmode)    ;(princ "\n76067133@qq.com") ) (defun @User2 (bit kwd msg def / inp)    (if def        (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")      bit (* 2 (fix (/ bit 2)))        )        (setq msg (strcat "\n" msg ": "))    )    (initget bit kwd)    (setq inp (getreal msg))    (if inp        inp        def    ) ) (defun mkla (name color)    (If (= (Tblsearch "layer" name) nil)        (Command "layer" "m" name "c" color name "")        (Command "layer" "t" name "s" name "c" color name "")    ) )

xstlf

xyp1964的这个子函数不错，呵呵，可以让程序减肥好多。谢谢提示。呵呵。