下面是一个填充图案的程序，我想把填充后的图案自动放到指定的图层内，图层名可以修改
下面是一个填充图案的程序，我想把填充后的图案自动放到指定的图层内，图层名可以修改，我想1个命令完成两个动作
(defun c:6y() (command "-BHATCH""p" "ansi31" "3" "0"))
本帖最后由 自贡黄明儒 于 2013-10-28 13:47 编辑
(defun c:6y()
(setq my (getvar "clayer"));当前层
(setvar "clayer" "1")
(command "-BHATCH""p" "ansi31" "3" "0")
(setvar "clayer" my)
(PRINC)
) 看不懂，麻烦给1个完整的程序. 重复1下比如：我的当前层是0我想把填充的图案自动放到图层1 你的程序的功能同我附上的程序的功能是一样的并没有什么区别，
写程序的时候可以先把当前图层0改成图层1，然后再填充，填充完后再把图层改成0这样就是拐了1下弯，思路可以是这样，哪个高手改1下 (defun c:6y(/ ss)
(setq ss(getstring "\n请输入指定图层:"))
(command "layer" "m" ss "")
(command "-BHATCH""p" "ansi31" "3" "0" pause)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
(setvar "clayer" "0")
(princ)
) G板的也有源码啊！
;自动转层 SunSpring http://bbs.mjtd.com/thread-86804-1-1.html
(defun xlr-autolayer ()
;; 图层初始化列表 内容：commands layers color linetype plottable
(setq *doc (vla-get-activedocument (vlax-get-acad-object)))
(setq *lays (vla-get-layers *doc))
(setq*laylst
(list
(list "dimlinear" "7标注" 3 "continuous" T) ;线性
(list "dimdiameter" "7标注" 3 "continuous" T);直径
(list "dimradius" "7标注" 3 "continuous" T) ;半径
(list "dimcontinue" "7标注" 3 "continuous" T);连续
(list "dimbaseline" "7标注" 3 "continuous" T);基准
(list "dimangular" "7标注" 3 "continuous" T) ;角度
(list "dimaligned" "7标注" 3 "continuous" T) ;对齐
(list "qleader" "7标注" 3 "continuous" T) ;引线
(list "dimordinate" "7标注" 3 "continuous" T);坐标标注
(list "qdim" "7标注" 3 "continuous" T) ;快速标注
(list "tolerance" "7标注" 3 "continuous" T) ;形位公差标注
(list "dtext" "9文字" 3 "continuous" T)
(list "mtext" "9文字" 3 "continuous" T)
(list "xline" "6不打印" 44 "continuous" T)
(list "text" "9文字" 253 "continuous" T)
(list "bhatch" "填充" 11 "continuous" T)
(list "hatch" "填充" 11 "continuous" T)
(list "dimcenter" "3中心线" 1 "continuous" T) ;圆心标记
;(list "POINT" "点" 4 "continuous" T)
;(list "LINE" "0" NIL "continuous" T)
;(list "XREF" "引用" 7 "continuous" T)
;(list "pline" "多义线" 2 "center" T)
)
)
(setq OldLayer nil)
(setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
(mapcar '(lambda (x) (vlr-command-reactor nil x))
(list'((:vlr-commandWillStart . xlr-start))
'((:vlr-commandEnded . xlr-end))
'((:vlr-commandCancelled . xlr-cancel))
)
)
(vlr-editor-reactor nil '((:vlr-commandwillstart . xlr-edit)))
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-edit(call callback / n)
(foreach n *laylst
(if(= (strcase (car callback)) (strcase (car n)))
(apply 'xsetlays (cdr n))
)
)
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-start (calling-reactor xlr-startinfo / n)
(foreach n *laylst
(if (= (strcase (car xlr-startinfo)) (strcase (car n)))
(apply 'xsetlays (cdr n))
)
)
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-end (calling-reactor xlr-endinfo / cmd)
(setq cmd (car xlr-endinfo))
(if (member cmd *cmdlst)
(if (/= oldlayer nil)
(progn
(setvar "clayer" oldlayer)
(setq oldlayer nil)
)
)
)
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-cancel (calling-reactor xlr-cancelinfo / cmd)
(setq cmd (car xlr-cancelinfo))
(if (member cmd *cmdlst)
(if (/= oldlayer nil)
(progn
(setvar "clayer" oldlayer)
(setq oldlayer nil)
)
)
)
)
;;;----------------------------------------------------------------------------;;;
(defun xsetlays(lay-nam color ltype plotk / layobj ltypesobj)
(defun layeron (layername / layerdata)
(setq layerdata (entget (tblobjname "LAYER" layername)))
(if (< (cdr (assoc 62 layerdata)) 0)
(progn
(setq layerdata (subst
(cons 62 (- 0 (cdr (assoc 62 layerdata))))
(assoc 62 layerdata)
layerdata
)
)
(entmod layerdata)
)
)
)
(if (tblobjname "layer" lay-nam)
(progn
(if (/= (strcase (getvar "clayer")) (strcase lay-nam))
(setq oldlayer (getvar "clayer"))
(progn
(if (= oldlayer nil)
(setq oldlayer lay-nam)
)
)
)
(layeron lay-nam)
(setvar "clayer" lay-nam)
)
(progn
(vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list *lays lay-nam)))
(setq layobj (vla-item *lays lay-nam))
(if (not (tblobjname "ltype" ltype)) ;添加线型.
(progn
(setq ltypesobj (vla-get-linetypes *doc))
(vla-load ltypesobj ltype (findfile "acad.lin"));>>> 要加强，在多个*.lin寻找
(vlax-release-object ltypesobj)
)
)
(vla-put-layeron layobj :vlax-true)
(vla-put-lock layobj :vlax-false)
(if (= (strcase (getvar "clayer")) (command "layer" "on" "" "")(strcase lay-nam)) ;解冻.
(vla-put-freeze layobj :vlax-false)
)
(vla-put-color layobj color)
(vla-put-linetype layobj LTYPE)
(vla-put-plottable layobj (if plotk :vlax-true :vlax-false))
)
)
)
;(xlr-autolayer) ;加载启动! 这个程序想改下，不需要输入指定图层，就是所放置的图层弄成自动转到图层1，不要去手动输入了(当前图层是0)所要放置的图层在程序里面可以修改
(defun c:6y(/ ss)
(setq ss(getstring "\n请输入指定图层:"))
(command "layer" "m" ss "")
(command "-BHATCH""p" "ansi31" "3" "0" pause)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
(setvar "clayer" "0")
(princ)
(defun c:tt ()
(if (= (tblsearch "layer" "1") nil)
(Command "-layer" "m" "1" "c" 1 "" "")
(Command "-layer" "t" "1" "")
)
(setvar "clayer" "1")
(princ "\n选择区域点: ")
(command "-BHATCH" "p" "ansi31" "3" "0" pause)
(while (> (getvar "CMDACTIVE") 0)
(command PAUSE)
(princ "\n选择区域点<回车完成>: ")
)
(setvar "clayer" "0")
(princ)
)
xyp1964的程序非常好，赞!!!! 程序必须要加错误处理(defun c:tt (/ *error* p li cm)
(defun *error* (x)
(command "undo" "e")
(setvar 'clayer li)
(setvar 'cmdecho cm)
(princ)
)
(setq li (getvar 'clayer)
cm (getvar 'cmdecho)
)
(setvar 'cmdecho 0)
(command "undo" "be")
(Command "-layer" "m" "1" "c" 1 "" "")
(setvar "clayer" "1")
(setq p (getpoint "\n →请点选:"))
(while p
(Command ".bhatch" "p" "" "" "" p "")
(setq p (getpoint "\r →请点选:"))
)
(*error* nil)
)
页:
[1]
2