[求助]：当用程序调用AutoCAD命令Fillet或Chamfer时遇到如半径不合适，或在某个方向上

mmmm · 发表于 2002-11-26 21:50:01

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

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

×

当用程序调用AutoCAD命令Fillet或Chamfer时遇到如半径不合适，或在某个方向上无法完成指定操作时，程序如何捕捉到错误的类型，或至少让程序能取消命令退出。

XDSoft · 发表于 2002-11-26 21:54:06

最初由 mmmm 发布
[B]当用程序调用AutoCAD命令Fillet或Chamfer时遇到如半径不合适，或在某个方向上无法完成指定操作时，程序如何捕捉到错误的类型，或至少让程序能取消命令退出。 [/B]

你可以在把参数送给FILLET等命令前，先自己程序判断下，不满足提示给用户，或者重输入，或者退出，这样程序健壮。

mmmm · 发表于 2002-11-26 22:04:45

但从图形学上讲，那样就变成自己编FILLET等命令了。我想那不是Visual LISP程序能做的。
实际上，在程序中我们会送两个变量（两次点取的线段）给AutoCAD，如果AutoCAD无法完成
正常的操作，命令不退出。我只是想要程序在这是判断下命令是否已经结束，如果没有，表示
送的变量无法完成操作，我只是希望程序能自动退出FILLET等命令以执行其他的代码。否则
程序在这里会被打断而崩溃

xlsbz · 发表于 2002-11-26 22:19:56

154481

梦断江南 · 发表于 2002-11-27 01:18:58

如果有新的实体产生，表示命令正常完成，反之。。。
(setq elast (entlast))
...
(command ".fillet")
(while roop
(setq pt1 () pt2 ()) ;;自己填
(command pt1 pt2)
(if (= elast (entlast)) (progn (command)(setq roop nil)))
...

XDSoft · 发表于 2002-11-27 01:45:13

最初由 mmmm 发布
[B]但从图形学上讲，那样就变成自己编FILLET等命令了。我想那不是Visual LISP程序能做的。
实际上，在程序中我们会送两个变量（两次点取的线段）给AutoCAD，如果AutoCAD无法完成
正常的操作，命令不退出。我只是想要?.. [/B]

判断命令是否结束，你可以用系统变量cmdactive

在COMMAND：提示状态，这个系统变量值＝0，否，在命令执行中。

[font=courier new]
[color=blue]CMDACTIVE[/color]
（只读）
类型：整数型
不保存
存储一个位码值，此位码值标识激活的是普通命令、透明命令、脚本还是对话框。本系统变量有以下可选位码值：
1 激活普通命令
2 激活普通命令和透明命令
4 激活脚本
8 激活对话框
16 激活 AutoLISP（仅 ObjectARX 定义的命令）
[/font]

复制代码

梦断江南 · 发表于 2002-11-27 02:34:06

贴个以前在001写的动态fillet倒角程序
其实这个程序对我没有什么用，当时只是为了验证一下所讨论的动态倒角问题。

[FONT=courier new]
(defun c:fd (/ opdmode ep1 ep2 pt1 opt roop cenpt fr gr pt2 n na)
(princ "\n fd=======动态fillet 倒圆角-----undo/b-------雄啸lxx.2001.5ok")
(princ "\n支持line,arc,*polyline,circle--除了*polyline+*polyline ")
(setq opdmode (getvar "pdmode"))
(command "undo" "m" "cmdecho" "0" "blipmode" "off" "pdmode" "2")
(while (not(setq ep1 (entsel "\n点取第一条线:"))))
(while (not(setq ep2 (entsel "\n点取第二条线:"))))
(setq pt1 (cadr ep2)
;pt1 (getpoint "\nfillet 半径第一点:")
opt pt1
roop "true"
fr (getvar "filletrad")
)
(princ "\n当前filletrad=")(princ fr)
(command "point" pt1 "filletrad" "");;; for undo
(setq cenpt (entlast))
(princ "\nfillet 半径第二点:")
(while roop
(defun *error* (msg)(command "undo" "1" "erase" cenpt "")(princ "\n错误:")(princ msg)(setq *error* nil))
(setq gr (grread t 7 0))
(if (/= (car gr) 5)
(setq roop nil)
(if (not(equal (cadr gr) opt));;;else
(progn
(command "undo" "1")
(setq pt2 (cadr gr)
fr (distance pt1 pt2)
opt pt2)
(princ "\n当前filletrad=")(princ fr)
(setvar "filletrad" fr)
(command "fillet" ep1 ep2 ^c)
);end progn
);end if
);end if
);end while
(setq *error* nil)
(if (= (car gr) 3);;;;;;;左键定filletrad
(setq pt2 (cadr gr)
fr (distance pt1 pt2))
)
(if (and (= (car gr) 2)
(and(< 47 (cadr gr))
(> 58 (cadr gr))
) );;;0~9 ascii 码值48~57
(setq n (chr(cadr gr))
na (getstring (strcat "\n键盘输入:filletrad=" n))
fr (atof (strcat n na))
)
)
(princ "\n当前filletrad=")(princ fr)
(command "undo" "1")
(setvar "filletrad" fr)
(command "fillet" ep1 ep2 ^c "erase" cenpt "")
(setvar "pdmode" opdmode)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:fd (/ opdmode ep1 ep2 pt1 opt roop cenpt fr gr pt2 n na) 
(princ "\n fd=======动态fillet 倒圆角-----undo/b-------雄啸lxx.2001.5ok") 
(princ "\n支持line,arc,*polyline,circle--除了*polyline+*polyline ") 
(setq opdmode (getvar "pdmode")) 
(command "undo" "m" "cmdecho" "0" "blipmode" "off" "pdmode" "2") 
(while (not(setq ep1 (entsel "\n点取第一条线:")))) 
(while (not(setq ep2 (entsel "\n点取第二条线:")))) 
(setq pt1 (cadr ep2) 
      ;pt1 (getpoint "\nfillet 半径第一点:") 
      opt pt1 
      roop "true" 
      fr (getvar "filletrad") 
) 
(princ "\n当前filletrad=")(princ fr) 
(command "point" pt1 "filletrad" "");;; for undo 
(setq cenpt (entlast)) 
(princ "\nfillet 半径第二点:") 
(while roop 
  (defun *error* (msg)(command "undo" "1" "erase" cenpt "")(princ "\n错误:")(princ msg)(setq *error* nil)) 
  (setq gr (grread t 7 0)) 
  (if (/= (car gr) 5) 
    (setq roop nil) 
    (if (not(equal (cadr gr) opt));;;else 
     (progn 
      (command "undo" "1") 
      (setq pt2 (cadr gr) 
            fr (distance pt1 pt2) 
            opt pt2) 
      (princ "\n当前filletrad=")(princ fr) 
      (setvar "filletrad" fr) 
      (command "fillet" ep1 ep2 ^c) 
     );end progn 
    );end if 
  );end if 
);end while 
(setq *error* nil) 
(if (= (car gr) 3);;;;;;;左键定filletrad 
  (setq  pt2 (cadr gr) 
         fr (distance pt1 pt2)) 
) 
(if (and (= (car gr) 2) 
         (and(< 47 (cadr gr)) 
             (> 58 (cadr gr)) 
    )    );;;0~9 ascii 码值48~57 
    (setq n (chr(cadr gr)) 
          na (getstring (strcat "\n键盘输入:filletrad=" n)) 
          fr (atof (strcat n na)) 
    ) 
) 
(princ "\n当前filletrad=")(princ fr) 
(command "undo" "1") 
(setvar "filletrad" fr) 
(command "fillet" ep1 ep2 ^c "erase" cenpt "") 
(setvar "pdmode" opdmode) 
(princ) 
) 
 
  [/FONT]

e2002 · 发表于 2002-11-27 09:36:03

这个问题是我觉得PKPM中有这个功能,希望AutoCAD也能实现而提出的...

江南兄牛刀小试即刻解决了....8-)

mmmm · 发表于 2002-11-27 21:02:06

问题解决了，这个问题解决后，我编的扩充AutoCAD的Fillet/Chamfer命令就能够完全正常运行了，当半径或距离过大时也不会出错，在调用的命令会给用户一条提示，正好成为程序的错误提示。意想不到的效果。
欢迎试用

;;; ******************************************************************** ;;;
;;; Command to enhance AutoCAD native Fillet command ;;;
;;; This application can processing Fillet between Line-Line ;;;
;;; Line-Polyline; Line-ARC; ARC-ARC; ARC-Polyline ;;;
;;; Polyline-Polyline and even different line or ARC segments ;;;
;;; of a same polyline ;;;
;;; ******************************************************************** ;;;
;;; KozMos Public Freeware Service [2002.01] ;;;
;;; Programmed by Yota Masaru ;;;
;;; Version: 2002.21124.1638 ;;;
;;; ReVersion: 2002.21127.2202 (quiet exit on too large radius) ;;;
;;; ******************************************************************** ;;;
(Defun C:MFillet (/ Sub_CheckValid XSub_GrDraw
OldCmd OldOsm Obj1 Obj2 Pt1
Pt2 SType Swidth SLayer SColor
Join TType SSet
)
;;; Sub-Function: [XSub_GrDraw]: Use GRDRAW with color 2 to redraw a line
;;; segments according to a point list
(Defun XSub_GrDraw (PointList Color / Start Next)
(if (> (length PointList) 1)
(progn
(setq Start (car PointList)
PointList (append PointList (list Start))
)
(repeat (1- (length PointList))
(setq Next (car PointList)
PointList (cdr PointList)
)
(grdraw Start Next Color)
(setq Start Next)
)
)
)
(princ)
)
;;; Sub-Function: [Sub_CheckValid]: Check if the segment picked by user
;;; is valid for running MFillet, the segment should be
;;; line or arc. If OK, Guse RDRAW to redraw that object
;;; with yellow.
;;; If a polyline is picked, the polyline will be exploded
;;; temperarily to check the segment.
(Defun Sub_CheckValid
(Data / XSub_GetRedrawData DataM Pt DType RedrawData Rtn)
(Defun XSub_GetRedrawData
(Obj / OType O10 O11 O40 O50 O51 Delta Rtn)
(setq OType (cdr (assoc 0 (entget Obj)))
O10 (cdr (assoc 10 (entget Obj)))
O11 (cdr (assoc 11 (entget Obj)))
O40 (cdr (assoc 40 (entget Obj)))
O50 (cdr (assoc 50 (entget Obj)))
O51 (cdr (assoc 51 (entget Obj)))
)
(cond ((= OType "LINE") (setq Rtn (list O10 O11)))
((= OType "ARC")
(if (< O51 O50)
(setq O51 (+ (* 2 pi) O51))
)
(setq Delta (/ (- O51 O50) 50.0))
(repeat 50
(setq Rtn (cons (polar O10 O50 O40) Rtn)
O50 (+ O50 Delta)
)
)
)
)
Rtn
)
(setq Pt (cadr Data)
Data (car Data)
DType (cdr (assoc 0 (entget Data)))
)
(cond ((member DType (list "ARC" "LINE"))
(setq Rtn T
RedrawData
(XSub_GetRedrawData Data)
)
)
((member DType (list "POLYLINE" "LWPOLYLINE"))
(command "_.Undo" "_Group");;; Prepare to explode
(command "_.Explode" Data)
(if
(member
(cdr (assoc 0 (entget (setq DataM (car (nentselp Pt))))))
(list "ARC" "LINE")
)
(setq Rtn T
Join T
RedrawData
(XSub_GetRedrawData DataM)
)
(alert (C:OAS_System_GetMessage -1031 nil))
)
(command "_.Undo" "_End")
(command "_U");;; disable this explode operation by undo it
)
)
(redraw Data 3)
(if RedrawData
(XSub_GrDraw RedrawData 2)
)
Rtn
)
(setq OldCmd (getvar "CmdEcho")
OldOsm (getvar "Osmode")
)
(setvar "CmdEcho" 0)
(princ (strcat "\n Current Fillet Radius: "
(rtos (getvar "FilletRad") 2 4)
)
)
(if
(setq
Obj1 (entsel
"\n Please pick the 1st (Base) Line/ARC/Polyline <Exit>:"
)
)
(if (Sub_CheckValid Obj1)
(if (setq Obj2
(entsel
"\r Please pick the 2nd (Joined) Line/ARC/Polyline <Exit>:"
)
)
(if (Sub_CheckValid Obj2)
(progn
(princ "\n")
(setq Pt1 (cadr Obj1)
Obj1 (car Obj1)
SType (cdr (assoc 0 (entget Obj1)))
Pt2 (cadr Obj2)
Obj2 (car Obj2)
TType (cdr (assoc 0 (entget Obj2)))
)
(if (and (equal SType "ARC")
(member TType (list "POLYLINE" "LWPOLYLINE"))
) ;;; force to order the source object. If only one polyline is picked
;;; this polyline should be the 1st object to fillet
;;; because the result will have same peroperties as the 1st object
(setq Rtn Obj1
Obj1 Obj2
Obj2 Rtn
Rtn Pt1
Pt1 Pt2
Pt2 Rtn
SType (cdr (assoc 0 (entget Obj1)))
TType (cdr (assoc 0 (entget Obj2)))
)
)
(if
(member TType (list "LINE" "POLYLINE" "LWPOLYLINE" "ARC"))
(progn
(setq SLayer (cdr (assoc 8 (entget Obj1)))
SWidth (cdr (assoc 40 (entget Obj1)))
SColor (cdr (assoc 62 (entget Obj1)))
)
(if (= TType "ARC")
(setq SWidth 0.0)
)
(if (null SColor)
(setq SColor "ByLayer")
)
(setvar "Osmode" 0)
(command "_.Undo" "_Group")
(command "_.Layer" "_M" "$SomZok$" "")
(command "_.Change" Obj1 Obj2
"" "_P" "_La" "$SomZok$"
""
) ;;; Create a temperory layer
(if (member SType (list "POLYLINE" "LWPOLYLINE"))
(command "_.Explode" Obj1)
)
(if
(and (not (equal Obj1 Obj2))
(member TType (list "POLYLINE" "LWPOLYLINE"))
)
(command "_.Explode" Obj2)
)
(setq Obj1 (car (nentselp Pt1))
Obj2 (car (nentselp Pt2))
)
(if (equal Obj1 Obj2)
(progn
(alert (strcat "\n Notice:"
"\n ======="
"\n Picked 2 objects are same object"
"\n can NOT run FILLET"
)
)
(command "_.Undo" "_End")
(command "_U")
)
(progn
(command "_.Undo" "_Group") ;;; This is added to prevent errors on too large radius on fillet
(command "_.Fillet"
(osnap Pt1 "Nea")
(osnap Pt2 "Nea")
)
(if (/= (getvar "CmdNames") "")
(progn ;; error found, the radius is too large
(command ^C)
(command "_.Undo" "_End")
(command "_U") ; close this level undo
(command "_.Undo" "_End")
(command "_U") ; close upper level undo
(command "_.Undo" "_End")
(command "_U") ; undo back to original
)
(progn ;; the radius is OK to fillet
(if (car (nentselp Pt1))
(if (null Join)
(command
"_.Change"
(ssget "x" (list (cons 8 "$SomZok$")))
""
"_P"
"_La"
SLayer
"_C"
SColor
""
)
(progn
(command
"_.PEdit"
(car (nentselp Pt1))
"_Y"
"_J"
(ssget "x" (list (cons 8 "$SomZok$")))
""
"_W"
SWidth
""
)
(command "_.Change"
(entlast)
""
"_P"
"_La"
SLayer
"_C"
SColor
""
)
)
)
)
(command "_.Undo" "_End")
)
)
)
)
)
)
)
)
)
)
)
(if (setq SSet (ssget "x" (list (cons 8 "$SomZok$"))))
(command "_.Erase" SSet "")
)
(command "_.Layer" "_S" "0" "")
(if (tblsearch "Layer" "$SomZok$")
(command "_.Purge" "_La" "$SomZok$" "N")
) ;;; Remove temperory layer
(redraw)
(if OldOsm
(setvar "Osmode" OldOsm)
)
(if OldCmd
(setvar "CmdEcho" OldCmd)
)
(princ)
)
;;; ******************************************************************** ;;;
;;; Command to enhance AutoCAD native Chamfer command ;;;
;;; This application can processing Chamfer between Line-Line ;;;
;;; Line-Polyline; Polyline-Polyline and even different line ;;;
;;; segments of a same polyline ;;;
;;; ******************************************************************** ;;;
;;; Same programming idea with MFillet ;;;
;;; ******************************************************************** ;;;
;;; KozMos Public Freeware Service [2002.02] ;;;
;;; Programmed by Yota Masaru ;;;
;;; Version: 2002.21124.1641 ;;;
;;; ReVersion: 2002.21127.2202 (quiet exit on too large distance) ;;;
;;; ******************************************************************** ;;;
(Defun C:MChamfer (/ Sub_CheckValid OldCmd OldOsm
Obj1 Obj2 Pt1 Pt2 SType
SWidth SLayer SColor TType TColor
TLayer TWidth SSet
)
(Defun Sub_CheckValid (Data / DataM Pt DType RedrawData Rtn)
(setq Pt (cadr Data)
Data (car Data)
DType (cdr (assoc 0 (entget Data)))
)
(cond
((= DType "LINE")
(setq Rtn T
RedrawData
(list (cdr (assoc 10 (entget Data)))
(cdr (assoc 11 (entget Data)))
)
)
)
((= DType "ARC")
(setq Rtn nil)
(alert (strcat "\n Picked segment on (LW)Polyline is ARC"
"\n Chamfer ARC is NOT valid"
"\n Press OK to quit"
)
)
)
((member DType (list "POLYLINE" "LWPOLYLINE"))
(command "_.Undo" "_Group")
(command "_.Explode" Data)
(if (= (cdr (assoc 0 (entget (setq DataM (car (nentselp Pt)))))
)
"LINE"
)
(setq Rtn T
RedrawData
(list (cdr (assoc 10 (entget DataM)))
(cdr (assoc 11 (entget DataM)))
)
)
(alert (strcat "\n Picked segment on (LW)Polyline is ARC"
"\n Chamfer ARC is NOT valid"
"\n Press OK to quit"
)
)
)
(command "_.Undo" "_End")
(command "_U")
)
)
(redraw Data 3)
(if RedrawData
(grdraw (nth 0 RedrawData) (nth 1 RedrawData) 2)
)
Rtn
)
(setq OldCmd (getvar "CmdEcho")
OldOsm (getvar "Osmode")
)
(setvar "CmdEcho" 0)
(princ (strcat "\n Current Chamfer Distance is:"
(rtos (getvar "ChamferA") 2 4)
" and "
(rtos (getvar "ChamferB") 2 4)
)
)
(if (setq Obj1 (entsel
"\n Please pick the 1st (Base) Line/Polyline <Exit>:"
)
)
(if (Sub_CheckValid Obj1)
(if (setq Obj2
(entsel
"\r Please pick the 2nd (Joined) Line/Polyline <Exit>:"
)
)
(if (Sub_CheckValid Obj2)
(progn
(setvar "Osmode" 0)
(princ "\n")
(command "_.Layer" "_M" "$SomZok$" "")
(setq Pt1 (cadr Obj1)
Obj1 (car Obj1)
SType (cdr (assoc 0 (entget Obj1)))
SLayer (cdr (assoc 8 (entget Obj1)))
SWidth (cdr (assoc 40 (entget Obj1)))
SColor (cdr (assoc 62 (entget Obj1)))
Pt2 (cadr Obj2)
Obj2 (car Obj2)
TType (cdr (assoc 0 (entget Obj2)))
TLayer (cdr (assoc 8 (entget Obj2)))
TWidth (cdr (assoc 40 (entget Obj2)))
TColor (cdr (assoc 62 (entget Obj2)))
)
(if (and (= SType "LINE")
(member TType (list "POLYLINE" "LWPOLYLINE"))
)
(setq SLayer TLayer
SWidth TWidth
SColor TColor
)
)
(if (null SColor)
(setq SColor "ByLayer")
)
(command "_.Undo" "_Group")
(command "_.Change" Obj1 Obj2 "" "_P" "_La" "$SomZok$" "")
(if (/= SType "LINE")
(command "_.Explode" Obj1)
)
(if (and (not (equal Obj1 Obj2))
(/= TType "LINE")
)
(command "_.Explode" Obj2)
)
(setq Obj1 (car (nentselp Pt1))
Obj2 (car (nentselp Pt2))
)
(cond
((equal Obj1 Obj2)
(alert (strcat "\n Notice:"
"\n ======="
"\n Picked 2 objects are same object"
"\n can NOT run CHAMFER"
)
)
(command "_.Undo" "_End")
(command "_U")
)
((null (inters (cdr (assoc 10 (entget Obj1)))
(cdr (assoc 11 (entget Obj1)))
(cdr (assoc 10 (entget Obj2)))
(cdr (assoc 11 (entget Obj2)))
nil
)
)
(alert (C:OAS_System_GetMessage -1033 nil))
(command "_.Undo" "_End")
(command "_U")
)
(t
(command "_.Undo" "_Group")
(command "_.Chamfer"
(osnap Pt1 "Nea")
(osnap Pt2 "Nea")
)
(if (/= (getvar "CmdNames") "")
(progn ;; error found
(command ^C)
(command "_.Undo" "_End")
(command "_U") ; close this level undo
(command "_.Undo" "_End")
(command "_U") ; close upper level undo
(command "_.Undo" "_End")
(command "_U") ; undo back to original
)
(progn
(setq SSet (ssget "x" (list (cons 8 "$SomZok$"))))
(if (= SType TType "LINE")
(command "_.Change" SSet ""
"_P" "_La" SLayer "_C"
SColor ""
)
(progn
(command "_.PEdit" Obj1 "_Y" "_J" SSet "" "_W"
SWidth "")
(command "_.Change"
(entlast)
""
"_P"
"_La"
SLayer
"_C"
SColor
""
)
)
)
(command "_.Undo" "_End")
)
)
)
)
)
)
)
)
)
(if (setq SSet (ssget "x" (list (cons 8 "$SomZok$"))))
(command "_.Erase" SSet "")
)
(command "_.Layer" "_S" "0" "")
(if (tblsearch "Layer" "$SomZok$")
(command "_.Purge" "_La" "$SomZok$" "N")
)
(redraw)
(if OldOsm
(setvar "Osmode" OldOsm)
)
(if OldCmd
(setvar "CmdEcho" OldCmd)
)
(princ)
)

;;; ******************************************************************** ;;; 
;;; Command to enhance AutoCAD native Fillet command                     ;;; 
;;; This application can processing Fillet between Line-Line             ;;; 
;;; Line-Polyline; Line-ARC; ARC-ARC; ARC-Polyline                       ;;; 
;;; Polyline-Polyline and even different line or ARC segments            ;;; 
;;; of a same polyline                                                   ;;; 
;;; ******************************************************************** ;;; 
;;; KozMos Public Freeware Service [2002.01]                             ;;; 
;;; Programmed by Yota Masaru                                            ;;; 
;;; Version: 2002.21124.1638                                             ;;; 
;;; ReVersion: 2002.21127.2202 (quiet exit on too large radius)          ;;; 
;;; Copyright(C) 1994-2002 by KozMos Inc.                                ;;; 
;;; All rights reserved                                                  ;;; 
;;; ******************************************************************** ;;; 
(Defun C:MFillet (/            Sub_CheckValid        XSub_GrDraw 
                  OldCmd    OldOsm    Obj1        Obj2          Pt1 
                  Pt2            SType     Swidth        SLayer          SColor 
                  Join            TType     SSet 
                 ) 
  ;;; Sub-Function: [XSub_GrDraw]: Use GRDRAW with color 2 to redraw a line 
  ;;;               segments according to a point list 
  (Defun XSub_GrDraw (PointList Color / Start Next) 
    (if        (> (length PointList) 1) 
      (progn 
        (setq Start        (car PointList) 
              PointList        (append PointList (list Start)) 
        ) 
        (repeat        (1- (length PointList)) 
          (setq        Next          (car PointList) 
                PointList (cdr PointList) 
          ) 
          (grdraw Start Next Color) 
          (setq Start Next) 
        ) 
      ) 
    ) 
    (princ) 
  ) 
  ;;; Sub-Function: [Sub_CheckValid]: Check if the segment picked by user 
  ;;;               is valid for running MFillet, the segment should be 
  ;;;               line or arc. If OK, Guse RDRAW to redraw that object 
  ;;;               with yellow. 
  ;;;               If a polyline is picked, the polyline will be exploded 
  ;;;               temperarily to check the segment. 
  (Defun Sub_CheckValid 
         (Data / XSub_GetRedrawData DataM Pt DType RedrawData Rtn) 
    (Defun XSub_GetRedrawData 
           (Obj / OType O10 O11 O40 O50 O51 Delta Rtn) 
      (setq OType (cdr (assoc 0 (entget Obj))) 
            O10          (cdr (assoc 10 (entget Obj))) 
            O11          (cdr (assoc 11 (entget Obj))) 
            O40          (cdr (assoc 40 (entget Obj))) 
            O50          (cdr (assoc 50 (entget Obj))) 
            O51          (cdr (assoc 51 (entget Obj))) 
      ) 
      (cond ((= OType "LINE") (setq Rtn (list O10 O11))) 
            ((= OType "ARC") 
             (if (< O51 O50) 
               (setq O51 (+ (* 2 pi) O51)) 
             ) 
             (setq Delta (/ (- O51 O50) 50.0)) 
             (repeat 50 
               (setq Rtn (cons (polar O10 O50 O40) Rtn) 
                     O50 (+ O50 Delta) 
               ) 
             ) 
            ) 
      ) 
      Rtn 
    ) 
 
    (setq Pt        (cadr Data) 
          Data        (car Data) 
          DType        (cdr (assoc 0 (entget Data))) 
    ) 
    (cond ((member DType (list "ARC" "LINE")) 
           (setq Rtn T 
                 RedrawData 
                  (XSub_GetRedrawData Data) 
           ) 
          ) 
          ((member DType (list "POLYLINE" "LWPOLYLINE")) 
           (command "_.Undo" "_Group");;; Prepare to explode 
           (command "_.Explode" Data) 
           (if 
             (member 
               (cdr (assoc 0 (entget (setq DataM (car (nentselp Pt)))))) 
               (list "ARC" "LINE") 
             ) 
              (setq Rtn        T 
                    Join T 
                    RedrawData 
                     (XSub_GetRedrawData DataM) 
              ) 
              (alert (C:OAS_System_GetMessage -1031 nil)) 
           ) 
           (command "_.Undo" "_End") 
           (command "_U");;; disable this explode operation by undo it 
          ) 
    ) 
    (redraw Data 3) 
    (if        RedrawData 
      (XSub_GrDraw RedrawData 2) 
    ) 
    Rtn 
  ) 
 
  (setq        OldCmd (getvar "CmdEcho") 
        OldOsm (getvar "Osmode") 
  ) 
  (setvar "CmdEcho" 0) 
  (princ (strcat "\n Current Fillet Radius: " 
                 (rtos (getvar "FilletRad") 2 4) 
         ) 
  ) 
  (if 
    (setq 
      Obj1 (entsel 
             "\n Please pick the 1st (Base) Line/ARC/Polyline <Exit>:" 
           ) 
    ) 
     (if (Sub_CheckValid Obj1) 
       (if (setq Obj2 
                  (entsel 
                    "\r Please pick the 2nd (Joined) Line/ARC/Polyline <Exit>:" 
                  ) 
           ) 
         (if (Sub_CheckValid Obj2) 
           (progn 
             (princ "\n") 
             (setq Pt1         (cadr Obj1) 
                   Obj1         (car Obj1) 
                   SType (cdr (assoc 0 (entget Obj1))) 
                   Pt2         (cadr Obj2) 
                   Obj2         (car Obj2) 
                   TType (cdr (assoc 0 (entget Obj2))) 
             ) 
             (if (and (equal SType "ARC") 
                      (member TType (list "POLYLINE" "LWPOLYLINE")) 
                 ) ;;; force to order the source object. If only one polyline is picked 
                   ;;; this polyline should be the 1st object to fillet 
                   ;;; because the result will have same peroperties as the 1st object 
               (setq Rtn   Obj1 
                     Obj1  Obj2 
                     Obj2  Rtn 
                     Rtn   Pt1 
                     Pt1   Pt2 
                     Pt2   Rtn 
                     SType (cdr (assoc 0 (entget Obj1))) 
                     TType (cdr (assoc 0 (entget Obj2))) 
               ) 
             ) 
             (if 
               (member TType (list "LINE" "POLYLINE" "LWPOLYLINE" "ARC")) 
                (progn 
                  (setq        SLayer (cdr (assoc 8 (entget Obj1))) 
                        SWidth (cdr (assoc 40 (entget Obj1))) 
                        SColor (cdr (assoc 62 (entget Obj1))) 
                  ) 
                  (if (= TType "ARC") 
                    (setq SWidth 0.0) 
                  ) 
                  (if (null SColor) 
                    (setq SColor "ByLayer") 
                  ) 
                  (setvar "Osmode" 0) 
                  (command "_.Undo" "_Group") 
                  (command "_.Layer" "_M" "$SomZok$" "") 
                  (command "_.Change"               Obj1         Obj2 
                           ""             "_P"      "_La"         "$SomZok$" 
                           "" 
                          ) ;;; Create a temperory layer 
                  (if (member SType (list "POLYLINE" "LWPOLYLINE")) 
                    (command "_.Explode" Obj1) 
                  ) 
                  (if 
                    (and (not (equal Obj1 Obj2)) 
                         (member TType (list "POLYLINE" "LWPOLYLINE")) 
                    ) 
                     (command "_.Explode" Obj2) 
                  ) 
                  (setq        Obj1 (car (nentselp Pt1)) 
                        Obj2 (car (nentselp Pt2)) 
                  ) 
                  (if (equal Obj1 Obj2) 
                    (progn 
                      (alert (strcat "\n Notice:" 
                                     "\n =======" 
                                     "\n Picked 2 objects are same object" 
                                     "\n can NOT run FILLET" 
                             ) 
                      ) 
                      (command "_.Undo" "_End") 
                      (command "_U") 
                    ) 
                    (progn 
                      (command "_.Undo" "_Group") ;;; This is added to prevent errors on too large radius on fillet 
                      (command "_.Fillet" 
                               (osnap Pt1 "Nea") 
                               (osnap Pt2 "Nea") 
                      ) 
                      (if (/= (getvar "CmdNames") "") 
                        (progn ;; error found, the radius is too large 
                               (command ^C) 
                               (command "_.Undo" "_End") 
                               (command "_U") ; close this level undo 
                               (command "_.Undo" "_End") 
                               (command "_U") ; close upper level undo 
                               (command "_.Undo" "_End") 
                               (command "_U") ; undo back to original 
                        ) 
                        (progn ;; the radius is OK to fillet 
                          (if (car (nentselp Pt1)) 
                            (if        (null Join) 
                              (command 
                                "_.Change" 
                                (ssget "x" (list (cons 8 "$SomZok$"))) 
                                "" 
                                "_P" 
                                "_La" 
                                SLayer 
                                "_C" 
                                SColor 
                                "" 
                              ) 
                              (progn 
                                (command 
                                  "_.PEdit" 
                                  (car (nentselp Pt1)) 
                                  "_Y" 
                                  "_J" 
                                  (ssget "x" (list (cons 8 "$SomZok$"))) 
                                  "" 
                                  "_W" 
                                  SWidth 
                                  "" 
                                ) 
                                (command "_.Change" 
                                         (entlast) 
                                         "" 
                                         "_P" 
                                         "_La" 
                                         SLayer 
                                         "_C" 
                                         SColor 
                                         "" 
                                ) 
                              ) 
                            ) 
                          ) 
                          (command "_.Undo" "_End") 
                        ) 
                      ) 
 
                    ) 
                  ) 
                ) 
             ) 
           ) 
         ) 
       ) 
     ) 
  ) 
  (if (setq SSet (ssget "x" (list (cons 8 "$SomZok$")))) 
    (command "_.Erase" SSet "") 
  ) 
  (command "_.Layer" "_S" "0" "") 
  (if (tblsearch "Layer" "$SomZok$") 
    (command "_.Purge" "_La" "$SomZok$" "N") 
  ) ;;; Remove temperory layer 
  (redraw) 
  (if OldOsm 
    (setvar "Osmode" OldOsm) 
  ) 
  (if OldCmd 
    (setvar "CmdEcho" OldCmd) 
  ) 
  (princ) 
) 
;;; ******************************************************************** ;;; 
;;; Command to enhance AutoCAD native Chamfer command                    ;;; 
;;; This application can processing Chamfer between Line-Line            ;;; 
;;; Line-Polyline; Polyline-Polyline and even different line             ;;; 
;;; segments of a same polyline                                          ;;; 
;;; ******************************************************************** ;;; 
;;; Same programming idea with MFillet                                   ;;; 
;;; ******************************************************************** ;;; 
;;; KozMos Public Freeware Service [2002.02]                             ;;; 
;;; Programmed by Yota Masaru                                            ;;; 
;;; Version: 2002.21124.1641                                             ;;; 
;;; ReVersion: 2002.21127.2202 (quiet exit on too large distance)        ;;; 
;;; Copyright(C) 1994-2002 by KozMos Inc.                                ;;; 
;;; All rights reserved                                                  ;;; 
;;; ******************************************************************** ;;; 
(Defun C:MChamfer (/             Sub_CheckValid         OldCmd           OldOsm 
                   Obj1             Obj2      Pt1         Pt2           SType 
                   SWidth    SLayer    SColor         TType           TColor 
                   TLayer    TWidth    SSet 
                  ) 
  (Defun Sub_CheckValid        (Data / DataM Pt DType RedrawData Rtn) 
    (setq Pt        (cadr Data) 
          Data        (car Data) 
          DType        (cdr (assoc 0 (entget Data))) 
    ) 
    (cond 
      ((= DType "LINE") 
       (setq Rtn T 
             RedrawData 
              (list (cdr (assoc 10 (entget Data))) 
                    (cdr (assoc 11 (entget Data))) 
              ) 
       ) 
      ) 
      ((= DType "ARC") 
       (setq Rtn nil) 
       (alert (strcat "\n Picked segment on (LW)Polyline is ARC" 
                      "\n Chamfer ARC is NOT valid" 
                      "\n Press OK to quit" 
              ) 
       ) 
      ) 
      ((member DType (list "POLYLINE" "LWPOLYLINE")) 
       (command "_.Undo" "_Group") 
       (command "_.Explode" Data) 
       (if (= (cdr (assoc 0 (entget (setq DataM (car (nentselp Pt))))) 
              ) 
              "LINE" 
           ) 
         (setq Rtn T 
               RedrawData 
                (list (cdr (assoc 10 (entget DataM))) 
                      (cdr (assoc 11 (entget DataM))) 
                ) 
         ) 
         (alert        (strcat        "\n Picked segment on (LW)Polyline is ARC" 
                        "\n Chamfer ARC is NOT valid" 
                        "\n Press OK to quit" 
                ) 
         ) 
       ) 
       (command "_.Undo" "_End") 
       (command "_U") 
      ) 
    ) 
    (redraw Data 3) 
    (if        RedrawData 
      (grdraw (nth 0 RedrawData) (nth 1 RedrawData) 2) 
    ) 
    Rtn 
  ) 
 
  (setq        OldCmd (getvar "CmdEcho") 
        OldOsm (getvar "Osmode") 
  ) 
  (setvar "CmdEcho" 0) 
  (princ (strcat "\n Current Chamfer Distance is:" 
                 (rtos (getvar "ChamferA") 2 4) 
                 " and " 
                 (rtos (getvar "ChamferB") 2 4) 
         ) 
  ) 
  (if (setq Obj1 (entsel 
                   "\n Please pick the 1st (Base) Line/Polyline <Exit>:" 
                 ) 
      ) 
    (if        (Sub_CheckValid Obj1) 
      (if (setq        Obj2 
                 (entsel 
                   "\r Please pick the 2nd (Joined) Line/Polyline <Exit>:" 
                 ) 
          ) 
        (if (Sub_CheckValid Obj2) 
          (progn 
            (setvar "Osmode" 0) 
            (princ "\n") 
            (command "_.Layer" "_M" "$SomZok$" "") 
            (setq Pt1         (cadr Obj1) 
                  Obj1         (car Obj1) 
                  SType         (cdr (assoc 0 (entget Obj1))) 
                  SLayer (cdr (assoc 8 (entget Obj1))) 
                  SWidth (cdr (assoc 40 (entget Obj1))) 
                  SColor (cdr (assoc 62 (entget Obj1))) 
                  Pt2         (cadr Obj2) 
                  Obj2         (car Obj2) 
                  TType         (cdr (assoc 0 (entget Obj2))) 
                  TLayer (cdr (assoc 8 (entget Obj2))) 
                  TWidth (cdr (assoc 40 (entget Obj2))) 
                  TColor (cdr (assoc 62 (entget Obj2))) 
            ) 
            (if        (and (= SType "LINE") 
                     (member TType (list "POLYLINE" "LWPOLYLINE")) 
                ) 
              (setq SLayer TLayer 
                    SWidth TWidth 
                    SColor TColor 
              ) 
            ) 
            (if        (null SColor) 
              (setq SColor "ByLayer") 
            ) 
            (command "_.Undo" "_Group") 
            (command "_.Change" Obj1 Obj2 "" "_P" "_La" "$SomZok$" "") 
            (if        (/= SType "LINE") 
              (command "_.Explode" Obj1) 
            ) 
            (if        (and (not (equal Obj1 Obj2)) 
                     (/= TType "LINE") 
                ) 
              (command "_.Explode" Obj2) 
            ) 
            (setq Obj1 (car (nentselp Pt1)) 
                  Obj2 (car (nentselp Pt2)) 
            ) 
            (cond 
              ((equal Obj1 Obj2) 
               (alert (strcat "\n Notice:" 
                              "\n =======" 
                              "\n Picked 2 objects are same object" 
                              "\n can NOT run CHAMFER" 
                      ) 
               ) 
               (command "_.Undo" "_End") 
               (command "_U") 
              ) 
              ((null (inters (cdr (assoc 10 (entget Obj1))) 
                             (cdr (assoc 11 (entget Obj1))) 
                             (cdr (assoc 10 (entget Obj2))) 
                             (cdr (assoc 11 (entget Obj2))) 
                             nil 
                     ) 
               ) 
               (alert (C:OAS_System_GetMessage -1033 nil)) 
               (command "_.Undo" "_End") 
               (command "_U") 
              ) 
              (t 
               (command "_.Undo" "_Group") 
               (command        "_.Chamfer" 
                        (osnap Pt1 "Nea") 
                        (osnap Pt2 "Nea") 
               ) 
               (if (/= (getvar "CmdNames") "") 
                 (progn        ;; error found 
                        (command ^C) 
                        (command "_.Undo" "_End") 
                        (command "_U")        ; close this level undo 
                        (command "_.Undo" "_End") 
                        (command "_U")        ; close upper level undo 
                        (command "_.Undo" "_End") 
                        (command "_U")        ; undo back to original 
                 ) 
                 (progn 
 
                   (setq SSet (ssget "x" (list (cons 8 "$SomZok$")))) 
                   (if (= SType TType "LINE") 
                     (command "_.Change"        SSet         "" 
                              "_P"     "_La"        SLayer         "_C" 
                              SColor   "" 
                             ) 
                     (progn 
                       (command        "_.PEdit" Obj1 "_Y" "_J" SSet "" "_W" 
                                SWidth "") 
                       (command        "_.Change" 
                                (entlast) 
                                "" 
                                "_P" 
                                "_La" 
                                SLayer 
                                "_C" 
                                SColor 
                                "" 
                       ) 
                     ) 
                   ) 
                   (command "_.Undo" "_End") 
                 ) 
               ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (if (setq SSet (ssget "x" (list (cons 8 "$SomZok$")))) 
    (command "_.Erase" SSet "") 
  ) 
  (command "_.Layer" "_S" "0" "") 
  (if (tblsearch "Layer" "$SomZok$") 
    (command "_.Purge" "_La" "$SomZok$" "N") 
  ) 
  (redraw) 
  (if OldOsm 
    (setvar "Osmode" OldOsm) 
  ) 
  (if OldCmd 
    (setvar "CmdEcho" OldCmd) 
  ) 
  (princ) 
)

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

[求助] [求助]：当用程序调用AutoCAD命令Fillet或Chamfer时遇到如半径不合适，或在某个方向上

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

相关帖子

Re: [求助]：当用程序调用AutoCAD命令Fillet或Chamfer时遇到如半径不合适，或在某个方向上无法完成指定操作时，程序如何捕捉到错误的类型，或至

浏览过的版块