带图案填充和
大家好，这是我的Lisp程序。它执行以下操作：
1） 将云线批注添加到多个图元中
2） 添加图层（或根据需要创建并添加特性）
3） 添加图案填充
4） 插入引线和文字的块（已格式化）
我对lisp的了解非常有限。正如你所见，我复制了几个不同的代码，并将其组合在一起，使其适用于我的应用程序。这是可行的，但我知道这一点也不系统。我不知道我的错误处理是否正确。
我想补充的一件事是，如果修订云太大或太小，它应该允许在不关闭和撤消所有内容的情况下这样做。从另一个意义上讲，我需要在此中撤消和重置弧长选项。有人能帮我吗？
(defun c:RVC6 (/ *error* oce mflag ans)
;************************************Error handling*********************************************
(defun *error* (msg)
(setvar "cmdecho" OCE)
(setq *error* nil)
(princ "\nRevision cloud program is done.")
(princ)
)
;************************************Program begins*********************************************
(setq OCE (getvar "cmdecho")
OOS (getvar "osmode")
)
(setvar "cmdecho" 0)
(setq mflag nil)
(while (not mflag)
(prompt "\n*** Enter option C, H, L, or E ***")
(initget 0 "Cloud Hatch Leader Exit")
(setq Ans (getkword "\nconvert to revision Cloud/Hatch/Leader/<Exit>: "))
(if (= Ans nil)
(setq Ans "Exit")
) ;end if
(cond
((= Ans "Cloud")
(convcloud)
)
((= Ans "Hatch")
(Addhatch)
)
((= Ans "Leader")
(Addleader)
)
((= Ans "Exit")
(setvar "cmdecho" OCE)
(setvar "osmode" OOS)
(quit)
)
) ;end cond
);end while
);end defun
;************************************Program ends**********************************************
;*******************************Start of "convcloud" program***********************************
(defun convcloud (/ al ss)
(initget (+ 2 4))
(setq al (getreal "Specify Arc length <0.5>:"))
(if (= al nil) ;If user do not input a value here
(setq al 0.5) ;Consider "Enter" as 0.5
) ; end if
(if (setq ss (ssget '((0 . "LINE,*POLYLINE,CIRCLE,ELLIPSE,SPLINE,ARC"))))
(progn
(repeat (setq i (sslength ss))
(command "_.revcloud" "a" al al "" (ssname ss (setq i (1- i))) "")
(if
(not (tblsearch "LAYER" "CONSTRUCTION"))
(command "-layer" "N" "CONSTRUCTION" "C" "1" "CONSTRUCTION" "LT" "continuous" "CONSTRUCTION" "")
) ; end if
(command ".-layer" "S" "CONSTRUCTION" "C" "red" "" "")
(Command "Chprop" "l" "" "la" "CONSTRUCTION" "C" "BYLAYER" "Lt" "BYLAYER" "LW" "BYLAYER" "")
);end repeat
(princ "\nRevision cloud(s) created on CONSTRUCTION layer.")
);end progn
(princ "\nNo objects selected.")
)
);end defun
;*******************************End of "convcloud" program*************************************
;*****************************Start of "Addhatch" Program *************************************
(defun Addhatch (/ htype selset thisobj setlen entname)
(initget 1 "D R")
(setq htype (getkword "\nSpecify hatch type? Demo(D)/Rebuild(R):"))
(if (= htype "D")
(setq htype "ANSI31")
) ;end if
(if (= htype "R")
(setq htype "DOTS")
) ;end if
(princ "\nSelect object(s) to hatch:")
(setq selset (ssget))
(if selset
(progn
(setq thisobj 0)
(setq setlen (sslength selset))
(while (< thisobj setlen )
(setq entname(ssname selset thisobj))
(Command "-bhatch" "Advanced" "Style" "Outer" "" "")
(command "-bhatch" "p" htype "3" "" "s" entname "" "")
(if
(not (tblsearch "LAYER" "CONSTRUCTION"))
(command "-layer" "N" "CONSTRUCTION" "C" "1" "CONSTRUCTION" "LT" "continuous" "CONSTRUCTION" "")
) ; end if
(command ".-layer" "S" "CONSTRUCTION" "C" "red" "" "")
(Command "Chprop" "l" "" "la" "CONSTRUCTION" "C" "BYLAYER" "Lt" "BYLAYER" "LW" "BYLAYER" "")
(setq thisobj(+ thisobj 1))
) ; end while
(alert "\n ***WARNING***
Hatching could not skip the inner objects.
To solve this, Double click hatch and `Add: select objects'
and select inner object & click OK")
) ; end progn
) ;end if selset
(princ "\nNo objects selected.")
);end defun
;*******************************End of "Addhatch" program*************************************
;*****************************Start of "Addleader" Program ***********************************
(defun Addleader (/ pt1)
(while
(setq pt1 (getpoint "\nInserting task description note, Specify Arrow End Point or hit Enter to close:"))
(Command "_INSERT" "CP TEXT" pt1 "" "" "")
(command "explode" "l")
);end while
);end defun
有人能帮我做这件事吗？
提前感谢
页:
[1]