[LISP程序]：怎么在CAD R14实现多义线倒直角呀！

flfuthpss · 发表于 2003-10-8 00:41:09

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

*-*9
请求大家帮助：
由于我是干建筑房产工作，经常用多义线(pline)画线，可以总是不能直接倒直角，使我的工作速度减慢，我想请大家帮助我，用LISP编程，让我解决这个问题。如果哪位大哥、大姐可以帮助我的话，请你发FLFUTHPSS@SOHU.COM或FLFUTHPSS@YAHOO.COM.CN
谢谢大家

eachy · 发表于 2003-10-8 07:06:22

换CAD2002就不用编程了

lsjjm · 发表于 2003-10-15 17:55:12

不是搞建筑的, 请问多义线倒直角是什么意思呀!?

coolzhb · 发表于 2003-10-16 09:50:04

我有类似的程序，但不成熟，就是pline线有转折就不行，好像xdapi可以很方便的搞定，希望高手编个lisp吧。

lsjjm · 发表于 2003-10-16 12:40:34

最初由 coolzhb 发布
[B]我有类似的程序... [/B]

贴出来让大家看看哪!?

coolzhb · 发表于 2003-10-16 14:50:48

我就贴出来！

[FONT=courier new]
(defun c:tpl (/ p1 p2 l1 l2 w1 w2 a1 a2 pt1 pt2 pt11 pt12 pt21 pt22 ps1 ps2
p0 mp1 mp2
)
(setq p1 (entsel)
p2 (entsel)
)
(setq l1 (entget (car p1))
l2 (entget (car p2))
)
(setq w1 (cdr (assoc 40 l1))
w2 (cdr (assoc 40 l2))
)
(command "explode" p1)
(setq a1 (entlast))
(command "explode" p2)
(setq a2 (entlast))
(setq pt1 (entget a1)
pt2 (entget a2)
pt11 (cdr (assoc 10 pt1))
pt12 (cdr (assoc 11 pt1))
pt21 (cdr (assoc 10 pt2))
pt22 (cdr (assoc 11 pt2))
ps1 (car (cdr p1))
ps2 (car (cdr p2))
)
(setq p0 (inters
pt11
pt12
pt21
pt22
nil
)
)
(setq mp1 (list 10 (car p0) (cadr p0))
mp2 (list 11 (car p0) (cadr p0))
)
(if (or
(< (* (- (car pt11) (car ps1)) (- (car p0) (car ps1))) 0)
(< (* (- (cadr pt11) (cadr ps1)) (- (cadr p0) (cadr ps1))) 0)
)
(setq pt1 (subst
mp2
(assoc 11 pt1)
pt1
)
)
(setq pt1 (subst
mp1
(assoc 10 pt1)
pt1
)
)
)
(entmod pt1)
(if (or
(< (* (- (car pt21) (car ps2)) (- (car p0) (car ps2))) 0)
(< (* (- (cadr pt21) (cadr ps2)) (- (cadr p0) (cadr ps2))) 0)
)
(setq pt2 (subst
mp2
(assoc 11 pt2)
pt2
)
)
(setq pt2 (subst
mp1
(assoc 10 pt2)
pt2
)
)
)
(entmod pt2)
(command "pedit" a1 "y" "w" (rtos w1 2 2) "")
(command "pedit" a2 "y" "w" (rtos w2 2 2) "")
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:tpl (/ p1 p2 l1 l2 w1 w2 a1 a2 pt1 pt2 pt11 pt12 pt21 pt22 ps1 ps2 
                                                                p0 mp1 mp2 
                                                 ) 
        (setq p1 (entsel) 
                                p2 (entsel) 
        ) 
        (setq l1 (entget (car p1)) 
                                l2 (entget (car p2)) 
        ) 
        (setq w1 (cdr (assoc 40 l1)) 
                                w2 (cdr (assoc 40 l2)) 
        ) 
        (command "explode" p1) 
        (setq a1 (entlast)) 
        (command "explode" p2) 
        (setq a2 (entlast)) 
        (setq pt1 (entget a1) 
                                pt2 (entget a2) 
                                pt11 (cdr (assoc 10 pt1)) 
                                pt12 (cdr (assoc 11 pt1)) 
                                pt21 (cdr (assoc 10 pt2)) 
                                pt22 (cdr (assoc 11 pt2)) 
                                ps1 (car (cdr p1)) 
                                ps2 (car (cdr p2)) 
        ) 
        (setq p0 (inters 
                                                 pt11 
                                                 pt12 
                                                 pt21 
                                                 pt22 
                                                 nil 
                                         ) 
        ) 
        (setq mp1 (list 10 (car p0) (cadr p0)) 
                                mp2 (list 11 (car p0) (cadr p0)) 
        ) 
        (if (or 
                                (< (* (- (car pt11) (car ps1)) (- (car p0) (car ps1))) 0) 
                                (< (* (- (cadr pt11) (cadr ps1)) (- (cadr p0) (cadr ps1))) 0) 
                        ) 
                (setq pt1 (subst 
                                                                mp2 
                                                                (assoc 11 pt1) 
                                                                pt1 
                                                        ) 
                ) 
                (setq pt1 (subst 
                                                                mp1 
                                                                (assoc 10 pt1) 
                                                                pt1 
                                                        ) 
                ) 
        ) 
        (entmod pt1) 
        (if (or 
                                (< (* (- (car pt21) (car ps2)) (- (car p0) (car ps2))) 0) 
                                (< (* (- (cadr pt21) (cadr ps2)) (- (cadr p0) (cadr ps2))) 0) 
                        ) 
                (setq pt2 (subst 
                                                                mp2 
                                                                (assoc 11 pt2) 
                                                                pt2 
                                                        ) 
                ) 
                (setq pt2 (subst 
                                                                mp1 
                                                                (assoc 10 pt2) 
                                                                pt2 
                                                        ) 
                ) 
        ) 
        (entmod pt2) 
        (command "pedit" a1 "y" "w" (rtos w1 2 2) "") 
        (command "pedit" a2 "y" "w" (rtos w2 2 2) "") 
        (princ) 
) 
 
  [/FONT]

coolzhb · 发表于 2003-10-16 14:55:59

还有一个，也贴出来！

[FONT=courier new]
(defun c:fi (/ pt1 pt2 e1 e2 s1 s2 r w1 w2 ne1 ne2 ls1 ls2 il)
(princ "剪切多义线\n")
(defun fi--err (msg)
(if (/= msg "*function cancelled*")
(princ (strcat "\nerror:" msg))
)
(princ)
)
(defun chkpline (is s w0 / il ne)
(setq il 0)
(while (< il is)
(progn
(setq ne (ssname s il))
(if (= (car (assoc 0 (entget ne))) "LINE")
(command "pedit" ne "" "w" w0 "")
)
(setq il (+ il 1))
)
)
)
(setq cmd (getvar "cmdecho"))
(setq os (getvar "osmode"))
(setq *error* fi--err)
(setvar "cmdecho" 0)
(setvar "osmode" 512)
(setq pt1 (getpoint "\n选择第一条线: "))
(setq pt2 (getpoint "\n选择第二条线: "))
(setq r0 (getvar "filletrad")) ; (prompt (strcat "\n输入圆角半径<"
; (rtos r0) ">:"))
; (initget 4)
; (setq r (getreal))
; (if (null r) (setq r r0))
(setq r 0)
(setvar "filletrad" r)
(setq e1 (ssget pt1))
(setq e2 (ssget pt2))
(setq ne1 (ssname e1 0))
(setq ne2 (ssname e2 0))
(setq w1 (cdr (assoc 40 (entget ne1))))
(setq w2 (cdr (assoc 40 (entget ne2))))
(if (equal (entget ne1) (entget ne2))
(progn
(command "explode" pt1)
(setq s1 (ssget "p"))
(setq ne1 (ssname e1 0))
(setq ls1 (sslength s1))
(setq e2 (ssget pt2))
(command "fillet" pt1 pt2)
(if (/= r 0)
(command "pedit" "l" "y" "w" w1 "")
)
(chkpline ls1 s1 w1)
)
(progn
(if (/= w1 nil)
(progn
(command "explode" pt1)
(setq s1 (ssget "p"))
(setq e1 (ssget pt1))
(setq ne1 (ssname e1 0))
(setq ls1 (sslength s1))
)
(setq ls1 0)
)
(if (/= w2 nil)
(progn
(command "explode" pt2)
(setq s2 (ssget "P"))
(setq e2 (ssget pt2))
(setq ne2 (ssname e2 0))
(setq ls2 (sslength s2))
)
(setq ls2 0)
)
(command "fillet" pt1 pt2)
(if (and
(/= r 0)
(/= w1 0)
)
(command "pedit" "L" "y" "w" w1 "")
)
(if (/= w1 nil)
(command "pedit" ne1 "y" "j" s1 "" "w" w1 "")
)
(if (/= w2 nil)
(command "pedit" ne2 "y" "j" s2 "" "w" w2 "")
)
(chkpline ls1 s1 w1)
(chkpline ls2 s2 w2)
)
)
(setvar "cmdecho" cmd)
(setvar "osmode" os)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:fi (/ pt1 pt2 e1 e2 s1 s2 r w1 w2 ne1 ne2 ls1 ls2 il) 
  (princ "剪切多义线\n") 
  (defun fi--err (msg) 
    (if (/= msg "*function cancelled*") 
      (princ (strcat "\nerror:" msg)) 
    ) 
    (princ) 
  ) 
  (defun chkpline (is s w0 / il ne) 
    (setq il 0) 
    (while (< il is) 
      (progn 
        (setq ne (ssname s il)) 
        (if (= (car (assoc 0 (entget ne))) "LINE") 
          (command "pedit" ne "" "w" w0 "") 
        ) 
        (setq il (+ il 1)) 
      ) 
    ) 
  ) 
  (setq cmd (getvar "cmdecho")) 
  (setq os (getvar "osmode")) 
  (setq *error* fi--err) 
  (setvar "cmdecho" 0) 
  (setvar "osmode" 512) 
  (setq pt1 (getpoint "\n选择第一条线: ")) 
  (setq pt2 (getpoint "\n选择第二条线: ")) 
  (setq r0 (getvar "filletrad"))       ; (prompt (strcat "\n输入圆角半径<" 
                                       ; (rtos r0) ">:")) 
                                       ; (initget 4) 
                                       ; (setq r (getreal)) 
                                       ; (if (null r) (setq r r0)) 
  (setq r 0) 
  (setvar "filletrad" r) 
  (setq e1 (ssget pt1)) 
  (setq e2 (ssget pt2)) 
  (setq ne1 (ssname e1 0)) 
  (setq ne2 (ssname e2 0)) 
  (setq w1 (cdr (assoc 40 (entget ne1)))) 
  (setq w2 (cdr (assoc 40 (entget ne2)))) 
  (if (equal (entget ne1) (entget ne2)) 
    (progn 
      (command "explode" pt1) 
      (setq s1 (ssget "p")) 
      (setq ne1 (ssname e1 0)) 
      (setq ls1 (sslength s1)) 
      (setq e2 (ssget pt2)) 
      (command "fillet" pt1 pt2) 
      (if (/= r 0) 
        (command "pedit" "l" "y" "w" w1 "") 
      ) 
      (chkpline ls1 s1 w1) 
    ) 
    (progn 
      (if (/= w1 nil) 
        (progn 
          (command "explode" pt1) 
          (setq s1 (ssget "p")) 
          (setq e1 (ssget pt1)) 
          (setq ne1 (ssname e1 0)) 
          (setq ls1 (sslength s1)) 
        ) 
        (setq ls1 0) 
      ) 
      (if (/= w2 nil) 
        (progn 
          (command "explode" pt2) 
          (setq s2 (ssget "P")) 
          (setq e2 (ssget pt2)) 
          (setq ne2 (ssname e2 0)) 
          (setq ls2 (sslength s2)) 
        ) 
        (setq ls2 0) 
      ) 
      (command "fillet" pt1 pt2) 
      (if (and 
            (/= r 0) 
            (/= w1 0) 
          ) 
        (command "pedit" "L" "y" "w" w1 "") 
      ) 
      (if (/= w1 nil) 
        (command "pedit" ne1 "y" "j" s1 "" "w" w1 "") 
      ) 
      (if (/= w2 nil) 
        (command "pedit" ne2 "y" "j" s2 "" "w" w2 "") 
      ) 
      (chkpline ls1 s1 w1) 
      (chkpline ls2 s2 w2) 
    ) 
  ) 
  (setvar "cmdecho" cmd) 
  (setvar "osmode" os) 
  (princ) 
) 
 
  [/FONT]

caoyu2006 · 发表于 2009-12-10 22:31:03

好东西，找好久了

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

[LISP程序]：怎么在CAD R14实现多义线倒直角呀！

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

浏览过的版块