一个画中空玻璃的lisp。求修改
做了个画中空玻璃的程序，只能做到图示一的地步，求修改到：yes、no的样式。yes是玻璃封口；no是不封口(defun c:blz ()
(command "undo" "group")
(setvar "osmode" 255)
(setvar "cmdecho" 0)
(while (setq p1 (getpoint "\n输入6+12+6中空玻璃第一点："))
(setq p2 (getpoint p1 "\n输入6+12+6中空玻璃下一点："))
(setvar "osmode" 0)
(command "line" p1 p2 "")
(setq ang (angle p1 p2))
(setq ang1 (+ ang (* pi 0.5)))
(setq ec (entlast))
(command "change" ec "" "p" "c" 2 "")
(command "line" (polar p1 ang1 24) (polar p2 ang1 24) "")
(setq ec1 (entlast))
(command "change" ec1 "" "p" "c" 2 "")
(command "line" (polar p1 ang1 1) (polar p2 ang1 1) "")
(setq ec2 (entlast))
(command "change" ec2 "" "p" "c" 8 "")
(command "line" (polar p1 ang1 5) (polar p2 ang1 5) "")
(setq ec4 (entlast))
(command "change" ec4 "" "p" "c" 8 "")
(command "line" (polar p1 ang1 6) (polar p2 ang1 6) "")
(setq ec5 (entlast))
(command "change" ec5 "" "p" "c" 2 "")
(command "line" (polar p1 ang1 18) (polar p2 ang1 18) "")
(setq ec6 (entlast))
(command "change" ec6 "" "p" "c" 2 "")
(command "line" (polar p1 ang1 19) (polar p2 ang1 19) "")
(setq ec3 (entlast))
(command "change" ec3 "" "p" "c" 8 "")
(command "line" (polar p1 ang1 23) (polar p2 ang1 23) "")
(setq ec3 (entlast))
(command "change" ec3 "" "p" "c" 8 "")
(setq dist (distance p1 p2)
ang(angle p1 p2)
)
(if (and (<= dist 39) (> dist 9))
(zx (polar p1 ang (/ (- dist 9) 2)) ang)
(progn (setq n (fix (/ dist 39)))
(repeat n
(zx (polar p1 ang (+ (* (1- n) 9) (* n 30))) ang)
(setq n (1- n))
)
)
)
(setvar "osmode" 255)
(command "undo" "end")
)
(princ) ;静默退出
)
附上dwg文件
图片看不清且缺函数 这个是单片玻璃的，改改就是中空玻璃了;;;&&&&&&&&&&开始检查是否存在图层，如无创建之函数&&&&&&&&&&
;;;=============================================
;;; 通用函数检查是否存在图层，如无创建之
;;;参数：l_p------打印标志(整型) 如果设置为 0，则不打印此图层
;;; l_l------线型(字符串)
;;; l_c------颜色(整型)
;;; l_s------图层状态(整型)
;;; l_n------图层名(字符串)
(defun ly_mak (l_p l_l l_c l_s l_n /)
(if (= (tblobjname "LAYER" l_n) nil)
(progn
(entmake (list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(if l_p
(cons 290 l_p)
'(290 . 1)
) ;_ 结束if
(if l_l
(cons 6 l_l)
'(6 . "CONTINUOUS")
) ;_ 结束if
(if l_c
(cons 62 l_c)
'(62 . 7)
) ;_ 结束if
(if l_s
(cons 70 l_s)
'(70 . 0)
) ;_ 结束if
(cons 2 l_n)
) ;_ 结束list
) ;_ 结束entmake
) ;_ 结束progn
) ;_ 结束if
) ;_ 结束defun
;;;修改组码en 图元名 num 组码 ch 修改为
(defun ch_dxf (en num ch / old_num new_num ent)
(if (setq ent (entget en)
new_num (cons num ch)
old_num (assoc num ent)
) ;_ 结束setq
(entmod (subst new_num old_num ent))
(entmod (reverse (cons new_num (reverse ent))))
) ;_ 结束if
) ;_ 结束defun
;;; 建立多段线
(defun emk_pl (width ptlist ly close_? / elem ed)
(setq ed (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length ptlist))
(cons 70
(if close_?
1
0
)
)
(cons 43 width)
(cons 67 0)
(cons 8 ly)
) ; list
) ;_ 结束setq
;;;setq
(foreach elem ptlist
(setq ed (append ed (list (cons 10 elem))))
)
;;;foreach
(entmake ed)
(entlast)
)
;;;单片玻璃绘制
(defun ghbl_draw (oi pt1 pt2 dist1 dist2 / pt ang lst1 lst2)
(setq ang(angle pt2 pt1)
lst1 (append (mapcar '(lambda (pt) (polar pt (+ ANG (/ PI 2)) DIST1))
(list pt2 pt1)
)
(mapcar '(lambda (pt) (polar pt (- ANG (/ PI 2)) DIST1))
(list pt1 pt2)
)
)
lst2 (append (mapcar '(lambda (pt) (polar pt (+ ANG (/ PI 2)) DIST2))
(list pt2 pt1)
)
(mapcar '(lambda (pt) (polar pt (- ANG (/ PI 2)) DIST2))
(list pt1 pt2)
)
)
)
(cond
((= OI "Yes")
(ch_dxf (emk_pl 0 lst1 "玻璃" t) 62 9)
(command "._chamfer" "d" (- dist2 dist1) (- dist2 dist1))
(command "._chamfer" "p" (emk_pl 0 lst2 "玻璃" t))
)
((= OI "No")
(ch_dxf (emk_pl 0 lst1 "玻璃" nil) 62 9)
(command "._chamfer" "d" (- dist2 dist1) (- dist2 dist1))
(command "._chamfer" "p" (emk_pl 0 lst2 "玻璃" nil))
)
)
)
(defun c:ghbl(/ old_luprec old_cmd oi dist1 dist2 pt1 pt2)
(setq old_luprec (getvar "luprec"))
(setq old_cmd (getvar "cmdecho"))
(setvar "luprec" 3)
(setvar "cmdecho" 0)
(ly_mak 1 "continuous" 2 0 "玻璃")
(initget 1 "A B C D E F G")
(if **ghblHDoi**
(SETQ OI (getkword
(STRCAT "\n玻璃厚度<" **ghblHDoi** ">")
)
)
(SETQ OI (getkword
"\n玻璃厚度<B>"
)
)
)
(SETQ **ghblHDoi** OI)
(COND ((= OI "A")
(SETQ dist1 1.
dist2 2.5
)
)
((= OI "B")
(SETQ dist1 1.5
dist2 3.
)
)
((= OI "C")
(SETQ dist1 2.5
dist2 4.
)
)
((= OI "D")
(SETQ dist1 3.5
dist2 5.
)
)
((= OI "E")
(SETQ dist1 4.5
dist2 6.
)
)
((= OI "F")
(SETQ dist1 6.
dist2 7.5
)
)
((= OI "G")
(SETQ dist1 7.5
dist2 9.5
)
)
)
(setq pt1(getpoint "\n拾取起点：")
pt2(getpoint pt1 "\n拾取终点：")
)
(initget 1 "Yes No")
(if **ghblKKoi**
(SETQ OI (getkword (STRCAT "\n[终点封口(Yes)/终点放开(No)]<" **ghblKKoi** ">")))
(SETQ OI (getkword "\n[终点封口(Yes)/终点放开(No)]<No>"))
)
(SETQ **ghblKKoi** OI)
(cond
((= OI "Yes")(ghbl_draw oi pt1 pt2 dist1 dist2))
((= OI "No")(ghbl_draw oi pt1 pt2 dist1 dist2))
)
(setvar "luprec" old_luprec)
(setvar "cmdecho" old_cmd)
(princ)
) 呵呵，可俺改不了啊，请老大出手 老大们，出手帮帮 顶起来，，，，，，，，，，，，，， ZZXXQQ 发表于 2013-5-1 03:58 static/image/common/back.gif
图片看不清且缺函数
6+12A+6中空玻璃 感谢分享感谢分享
页:
[1]