一个画中空玻璃的lisp。求修改

bai2000 · 发表于 2013-4-26 21:41

做了个画中空玻璃的程序，只能做到图示一的地步，求修改到：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文件

ZZXXQQ · 发表于 2013-4-27 08:58

图片看不清且缺函数

x_s_s_1 · 发表于 2013-4-27 09:11

这个是单片玻璃的，改改就是中空玻璃了

;;;&&&&&&&&&&开始检查是否存在图层，如无创建之函数&&&&&&&&&&
;;;=============================================
;;; 通用函数检查是否存在图层，如无创建之
;;;参数：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玻璃厚度[5(A)/6(B)/8(C)/10(D)/12(E)/15(F)/19(G)]<" **ghblHDoi** ">")
)
)
(SETQ OI (getkword
"\n玻璃厚度[5(A)/6(B)/8(C)/10(D)/12(E)/15(F)/19(G)]"
)
)
)
(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)
)

;;;&&&&&&&&&&开始检查是否存在图层，如无创建之函数&&&&&&&&&& 
;;;============================================= 
;;;      通用函数  检查是否存在图层，如无创建之               
;;;参数：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玻璃厚度[5(A)/6(B)/8(C)/10(D)/12(E)/15(F)/19(G)]<" **ghblHDoi** ">") 
           ) 
  ) 
  (SETQ        OI (getkword 
             "\n玻璃厚度[5(A)/6(B)/8(C)/10(D)/12(E)/15(F)/19(G)]" 
           ) 
  ) 
    ) 
  (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) 
)

bai2000 · 发表于 2013-4-27 11:41

呵呵，可俺改不了啊，请老大出手

bai2000 · 发表于 2013-4-29 14:02

老大们，出手帮帮

bai2000 · 发表于 2013-5-24 17:16

顶起来，，，，，，，，，，，，，，

ucuc2003 · 发表于 2013-5-24 22:50

ZZXXQQ 发表于 2013-5-1 03:58
图片看不清且缺函数

6+12A+6中空玻璃

yefei812678 · 发表于 2024-3-22 08:08

感谢分享感谢分享

账号		自动登录	找回密码
密码			注册

[基础] 一个画中空玻璃的lisp。求修改

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源