自动图层
这个是在明经上找到的自动图层，当标注时就自动转到dim层，非常 好用，只是当我单开一个其它图层时，标注的层dim是被关闭的，结果就看不到所标注的东东，要全开图层才行，请问可不可以加一个功能，让程序在标注时，会自动打开标注层dim（形如下载的地方没找到，只好在这里从新发一个了）(defun xlr-autolayer ()(vl-load-com)
;; 图层初始化列表 内容：commands layers color linetype plottable
(setq *doc (vla-get-activedocument (vlax-get-acad-object)))
(setq *lays (vla-get-layers *doc))
(setq*laylst
(list (list "DIMANGULAR" "DIM" 3 "continuous" T)
(list "DIMALIGNED" "DIM" 3 "continuous" T)
(list "DIMBASELINE" "DIM" 3 "continuous" T)
(list "DIMCENTER" "DIM" 3 "continuous" T)
(list "DIMCONTINUE" "DIM" 3 "continuous" T)
(list "DIMDIAMETER" "DIM" 3 "continuous" T)
(list "DIMLINEAR" "DIM" 3 "continuous" T)
(list "DIMORDINATE" "DIM" 3 "continuous" T)
(list "DIMRADIUS" "DIM" 3 "continuous" T)
(list "QDIM" "DIM" 3 "continuous" T)
(list "QLEADER" "DIM" 3 "continuous" T)
(list "DTEXT" "TXT" 3 "continuous" T)
(list "MTEXT" "TXT" 3 "continuous" T)
(list "TEXT" "TXT" 3 "continuous" T)
;(list "BHATCH" "填充" 9 "continuous" T)
;(list "HATCH" "填充" 9 "continuous" T)
;(list "POINT" "点" 4 "continuous" T)
;(list "XLINE" "辅助线" 8 "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 /)
(foreach N *laylst
(if(= (strcase (car CALLBACK)) (strcase (car N)))
; 命令反应器返回信息如果与设置的命令相同.
(progn ;建立图层
(apply 'xsetlays (cdr N))
;(setvar "CLAYER" (cadr N));设为当前层.
)
)
)
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-start (calling-reactor xlr-startInfo /)
(foreach N *laylst
(if(= (strcase (car xlr-startInfo)) (strcase (car N)))
; 命令反应器返回信息如果与设置的命令相同.
(progn ;建立图层
(apply 'xsetlays (cdr N))
;(setvar "CLAYER" (cadr 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)
(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)
)
)
)
(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) ;加载启动!
SunSpring 发表于 2011-5-11 20:37 static/image/common/back.gif
试下这个如何.
把124行的(vla-put-color layobj color)放到121行前面去，不然设置的图层颜色不起作用 ㄘ丶转裑ㄧ灬 发表于 2016-5-15 20:34
把124行的(vla-put-color layobj color)放到121行前面去，不然设置的图层颜色不起作用
大神呀，我说怎么颜色都是白的 大家看下面的帖子
关于标注自动分层
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=173161&highlight=%B1%EA%D7%A2 期待高手来解决 自动图层，扬起~ 我知道需要命令才可实现标注自动到标注层 我把它顶起来 本帖最后由 SunSpring 于 2011-5-11 20:38 编辑
(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 "DIMANGULAR" "DIM" 3 "continuous" T)
(list "DIMALIGNED" "DIM" 3 "continuous" T)
(list "DIMBASELINE" "DIM" 3 "continuous" T)
(list "DIMCENTER" "DIM" 3 "continuous" T)
(list "DIMCONTINUE" "DIM" 3 "continuous" T)
(list "DIMDIAMETER" "DIM" 3 "continuous" T)
(list "DIMLINEAR" "DIM" 3 "continuous" T)
(list "DIMORDINATE" "DIM" 3 "continuous" T)
(list "DIMRADIUS" "DIM" 3 "continuous" T)
(list "QDIM" "DIM" 3 "continuous" T)
(list "QLEADER" "DIM" 3 "continuous" T)
(list "DTEXT" "TXT" 3 "continuous" T)
(list "MTEXT" "TXT" 3 "continuous" T)
(list "TEXT" "TXT" 3 "continuous" T)
;(list "BHATCH" "填充" 9 "continuous" T)
;(list "HATCH" "填充" 9 "continuous" T)
;(list "POINT" "点" 4 "continuous" T)
;(list "XLINE" "辅助线" 8 "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) ;加载启动!
试下这个如何.
回复 SunSpring 的帖子
谢谢楼主，这个非常好用 是龙版主的Autolayer差不多的吧 SunSpring 发表于 2011-5-11 20:37 static/image/common/back.gif
试下这个如何.
我写了几句插入时间的程序，用了你的自动图层后，系统就崩溃了。
;插入时间
(defun hh-time( / pt0 date0 scal pt1)
(vl-cmdf "ucs" "")
(setq scal (getvar "dimscale"))
(setq pt0 (getpoint "\n点取时间插入右下角:"))
(setq pt0 (polar pt0 PI (* 1.5 scal)))
(setq pt0 (polar pt0 (/ pi 2) (* 1.25 scal)))
(setq date0 (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD)"))
(setq pt1 (polar pt0 PI (* 12 scal)))
(vl-cmdf "text" "j" "f" pt1 pt0 (* 3.5 scal) date0)
(princ)
) 本帖最后由 啵浪鼓 于 2011-5-23 02:53 编辑
挺好的反应器
解冻/解锁
(if (/= (cdr (assoc 70 layerdata)) 0)
(progn
(setq layerdata (subst
(cons 70 0)
(assoc 70 layerdata)
layerdata
)
)
(entmod layerdata)
)
)