自动图层

yxl88168

这个是在明经上找到的自动图层，当标注时就自动转到dim层，非常 好用，只是当我单开一个其它图层时，标注的层dim是被关闭的，结果就看不到所标注的东东，要全开图层才行，请问可不可以加一个功能，让程序在标注时，会自动打开标注层dim（形如下载的地方没找到，只好在这里从新发一个了）

2. (defun xlr-autolayer ()
   
3.   (vl-load-com)
   
4.   ;; 图层初始化列表 内容：commands layers color linetype plottable
   
5.   (setq *doc (vla-get-activedocument (vlax-get-acad-object)))
   
6.   (setq *lays (vla-get-layers *doc))
   
7.   (setq  *laylst
   
8.    (list (list "DIMANGULAR" "DIM" 3 "continuous" T)
   
9.          (list "DIMALIGNED" "DIM" 3 "continuous" T)
   
10.          (list "DIMBASELINE" "DIM" 3 "continuous" T)
    
11.          (list "DIMCENTER" "DIM" 3 "continuous" T)
    
12.          (list "DIMCONTINUE" "DIM" 3 "continuous" T)
    
13.          (list "DIMDIAMETER" "DIM" 3 "continuous" T)
    
14.          (list "DIMLINEAR" "DIM" 3 "continuous" T)
    
15.          (list "DIMORDINATE" "DIM" 3 "continuous" T)
    
16.          (list "DIMRADIUS" "DIM" 3 "continuous" T)
    
17.          (list "QDIM" "DIM" 3 "continuous" T)
    
18.          (list "QLEADER" "DIM" 3 "continuous" T)
    
19.          (list "DTEXT" "TXT" 3 "continuous" T)
    
20.          (list "MTEXT" "TXT" 3 "continuous" T)
    
21.          (list "TEXT" "TXT" 3 "continuous" T)
    
22.          ;(list "BHATCH" "填充" 9 "continuous" T)
    
23.          ;(list "HATCH" "填充" 9 "continuous" T)
    
24.           ;(list "POINT" "点" 4 "continuous" T)
    
25.           ;(list "XLINE" "辅助线" 8 "continuous" T)
    
26.           ;(list "LINE" "0" NIL "continuous" T)
    
27.           ;(list "XREF" "引用" 7 "continuous" T)
    
28.           ;(list "pline" "多义线" 2 "center" T)
    
29.    )
    
30.   )
    
31.   (setq OldLayer nil)
    
32.   (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
    
33.   (mapcar '(lambda (x) (vlr-command-reactor nil x))
    
34.     (list  '((:vlr-commandWillStart . xlr-start))
    
35.     '((:vlr-commandEnded . xlr-end))
    
36.     '((:vlr-commandCancelled . xlr-cancel))
    
37.     )
    
38.   )
    
39.   (vlr-editor-reactor
    
40.     nil
    
41.     '((:vlr-commandwillstart . xlr-edit))
    
42.   )
    
43. )
    
44. ;;;----------------------------------------------------------------------------;;;
    
45. (defun xlr-edit  (CALL CALLBACK /)
    
46.   (foreach N *laylst
    
47.     (if  (= (strcase (car CALLBACK)) (strcase (car N)))
    
48.           ; 命令反应器返回信息如果与设置的命令相同.
    
49.       (progn        ;建立图层
    
50. 
    
51.   (apply 'xsetlays (cdr N))
    
52.           ;(setvar "CLAYER" (cadr N));设为当前层.
    
53.       )
    
54.     )
    
55.   )
    
56. )
    
57. ;;;----------------------------------------------------------------------------;;;
    
58. (defun xlr-start (calling-reactor xlr-startInfo /)
    
59.   (foreach N *laylst
    
60.     (if  (= (strcase (car xlr-startInfo)) (strcase (car N)))
    
61.           ; 命令反应器返回信息如果与设置的命令相同.
    
62.       (progn        ;建立图层
    
63. 
    
64.   (apply 'xsetlays (cdr N))
    
65.           ;(setvar "CLAYER" (cadr N));设为当前层.
    
66.       )
    
67.     )
    
68.   )
    
69. )
    
70. ;;;----------------------------------------------------------------------------;;;
    
71. (defun xlr-end (calling-reactor xlr-endInfo / cmd)
    
72.   (setq cmd (car xlr-endInfo))
    
73.   (if (member cmd *cmdlst)
    
74.     (if (/= oldlayer nil)
    
75.        (progn
    
76.            (setvar "CLAYER" OldLayer)
    
77.            (setq OldLayer nil)
    
78.        )
    
79.     )
    
80.   )
    
81. )
    
82. ;;;----------------------------------------------------------------------------;;;
    
83. (defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)
    
84.   (setq cmd (car xlr-cancelInfo))
    
85.   (if (member cmd *cmdlst)
    
86.     (if (/= oldlayer nil)
    
87.        (progn
    
88.            (setvar "CLAYER" OldLayer)
    
89.            (setq OldLayer nil)
    
90.        )
    
91.     )
    
92.   )
    
93. )
    
94. ;;;----------------------------------------------------------------------------;;;
    
95. ;;;----------------------------------------------------------------------------;;;
    
96. (defun xsetlays  (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)
    
97. 
    
98.   (if (tblobjname "layer" LAY-NAM)
    
99.     (progn
    
100.       (if (/= (strcase (getvar "CLAYER"))
     
101.         (strcase LAY-NAM)
     
102.     )
     
103.   (setq OldLayer (getvar "CLAYER"))
     
104.   (progn
     
105.     (if (= oldlayer nil)
     
106.       (setq OldLayer LAY-NAM)
     
107.     )
     
108.   )
     
109.       )
     
110.       (setvar "CLAYER" lay-nam)
     
111.     )
     
112.     (progn        ;添加图层.
     
113.       (vl-catch-all-error-p
     
114.   (vl-catch-all-apply 'vla-add (list *lays LAY-NAM))
     
115.       )
     
116.       (setq LAYOBJ (vla-item *lays LAY-NAM))
     
117.       (if (not (tblobjname "ltype" LTYPE)) ;添加线型.
     
118.   (progn
     
119.     (setq LTYPESOBJ (vla-get-linetypes *doc))
     
120.     (vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))
     
121.           ;>>>　要加强，在多个*.lin寻找
     
122.     (vlax-release-object LTYPESOBJ)
     
123.   )
     
124.       )          ;解冻(如冻结)，解锁,设图层为当前,设图层颜色，可打印特性.
     
125.       (vla-put-layeron layobj :vlax-true)
     
126.       (vla-put-lock layobj :vlax-false)
     
127.       (if (= (strcase (getvar "CLAYER")) (COMMAND "layer" "on" "" "")(strcase lay-nam)) ;解冻.
     
128.   (vla-put-freeze layobj :vlax-false)
     
129.       )
     
130.       (vla-put-color layobj color)
     
131.       (vla-put-linetype layobj LTYPE)
     
132.       (vla-put-plottable
     
133.   layobj
     
134.   (if plotk
     
135.     :vlax-true
     
136.     :vlax-false
     
137.   )
     
138.       )
     
139.     )
     
140.   )
     
141. )
     
142. (xlr-autolayer)        ;加载启动!

(defun xlr-autolayer ()<br />   (vl-load-com)<br />   ;; 图层初始化列表 内容：commands layers color linetype plottable<br />   (setq *doc (vla-get-activedocument (vlax-get-acad-object)))<br />   (setq *lays (vla-get-layers *doc))<br />   (setq  *laylst <br />    (list (list "DIMANGULAR" "DIM" 3 "continuous" T)<br />          (list "DIMALIGNED" "DIM" 3 "continuous" T)<br />          (list "DIMBASELINE" "DIM" 3 "continuous" T)<br />          (list "DIMCENTER" "DIM" 3 "continuous" T)<br />          (list "DIMCONTINUE" "DIM" 3 "continuous" T)<br />          (list "DIMDIAMETER" "DIM" 3 "continuous" T)<br />          (list "DIMLINEAR" "DIM" 3 "continuous" T)<br />          (list "DIMORDINATE" "DIM" 3 "continuous" T)<br />          (list "DIMRADIUS" "DIM" 3 "continuous" T)<br />          (list "QDIM" "DIM" 3 "continuous" T)<br />          (list "QLEADER" "DIM" 3 "continuous" T)<br />          (list "DTEXT" "TXT" 3 "continuous" T)<br />          (list "MTEXT" "TXT" 3 "continuous" T)<br />          (list "TEXT" "TXT" 3 "continuous" T)<br />          ;(list "BHATCH" "填充" 9 "continuous" T)<br />          ;(list "HATCH" "填充" 9 "continuous" T)<br />           ;(list "POINT" "点" 4 "continuous" T)<br />           ;(list "XLINE" "辅助线" 8 "continuous" T)<br />           ;(list "LINE" "0" NIL "continuous" T)<br />           ;(list "XREF" "引用" 7 "continuous" T)<br />           ;(list "pline" "多义线" 2 "center" T)<br />    )<br />   )<br />   (setq OldLayer nil)<br />   (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))<br />   (mapcar '(lambda (x) (vlr-command-reactor nil x))<br />     (list  '((:vlr-commandWillStart . xlr-start))<br />     '((:vlr-commandEnded . xlr-end))<br />     '((:vlr-commandCancelled . xlr-cancel))<br />     )<br />   )<br />   (vlr-editor-reactor<br />     nil<br />     '((:vlr-commandwillstart . xlr-edit))<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-edit  (CALL CALLBACK /)<br />   (foreach N *laylst<br />     (if  (= (strcase (car CALLBACK)) (strcase (car N)))<br />           ; 命令反应器返回信息如果与设置的命令相同.<br />       (progn        ;建立图层<br /> <br />   (apply 'xsetlays (cdr N))<br />           ;(setvar "CLAYER" (cadr N));设为当前层.<br />       )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-start (calling-reactor xlr-startInfo /)<br />   (foreach N *laylst<br />     (if  (= (strcase (car xlr-startInfo)) (strcase (car N)))<br />           ; 命令反应器返回信息如果与设置的命令相同.<br />       (progn        ;建立图层<br /> <br />   (apply 'xsetlays (cdr N))<br />           ;(setvar "CLAYER" (cadr N));设为当前层.<br />       )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-end (calling-reactor xlr-endInfo / cmd)<br />   (setq cmd (car xlr-endInfo))<br />   (if (member cmd *cmdlst)<br />     (if (/= oldlayer nil)<br />        (progn <br />            (setvar "CLAYER" OldLayer)<br />            (setq OldLayer nil)<br />        )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)<br />   (setq cmd (car xlr-cancelInfo))<br />   (if (member cmd *cmdlst)<br />     (if (/= oldlayer nil)<br />        (progn <br />            (setvar "CLAYER" OldLayer)<br />            (setq OldLayer nil)<br />        )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> ;;;----------------------------------------------------------------------------;;; <br /> (defun xsetlays  (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)<br /> <br />   (if (tblobjname "layer" LAY-NAM)<br />     (progn<br />       (if (/= (strcase (getvar "CLAYER"))<br />         (strcase LAY-NAM)<br />     )<br />   (setq OldLayer (getvar "CLAYER"))<br />   (progn<br />     (if (= oldlayer nil)<br />       (setq OldLayer LAY-NAM)<br />     )<br />   )<br />       )<br />       (setvar "CLAYER" lay-nam)<br />     )<br />     (progn        ;添加图层.<br />       (vl-catch-all-error-p<br />   (vl-catch-all-apply 'vla-add (list *lays LAY-NAM))<br />       )<br />       (setq LAYOBJ (vla-item *lays LAY-NAM))<br />       (if (not (tblobjname "ltype" LTYPE)) ;添加线型.<br />   (progn<br />     (setq LTYPESOBJ (vla-get-linetypes *doc))<br />     (vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))<br />           ;>>>　要加强，在多个*.lin寻找<br />     (vlax-release-object LTYPESOBJ)<br />   )<br />       )          ;解冻(如冻结)，解锁,设图层为当前,设图层颜色，可打印特性.<br />       (vla-put-layeron layobj :vlax-true)<br />       (vla-put-lock layobj :vlax-false)<br />       (if (= (strcase (getvar "CLAYER")) (COMMAND "layer" "on" "" "")(strcase lay-nam)) ;解冻.<br />   (vla-put-freeze layobj :vlax-false)<br />       )<br />       (vla-put-color layobj color)<br />       (vla-put-linetype layobj LTYPE)<br />       (vla-put-plottable<br />   layobj<br />   (if plotk<br />     :vlax-true<br />     :vlax-false<br />   )<br />       )<br />     )<br />   )<br /> )<br /> (xlr-autolayer)        ;加载启动!

ㄘ丶转裑ㄧ灬

SunSpring 发表于 2011-5-11 20:37
试下这个如何.

把124行的(vla-put-color layobj color)放到121行前面去，不然设置的图层颜色不起作用

qq112648819

ㄘ丶转裑ㄧ灬 发表于 2016-5-15 20:34
把124行的(vla-put-color layobj color)放到121行前面去，不然设置的图层颜色不起作用

大神呀，我说怎么颜色都是白的

shcvip

大家看下面的帖子
关于标注自动分层
http://bbs.mjtd.com/forum.php?mo ... hlight=%B1%EA%D7%A2

yxl88168

期待高手来解决

zxjing

自动图层，扬起~

zhouwanweihf

我知道需要命令才可实现标注自动到标注层

yxl88168

我把它顶起来

SunSpring

1. (defun xlr-autolayer ()
   
2.   ;; 图层初始化列表 内容：commands layers color linetype plottable
   
3.   (setq *doc (vla-get-activedocument (vlax-get-acad-object)))
   
4.   (setq *lays (vla-get-layers *doc))
   
5.   (setq  *laylst
   
6.     (list (list "DIMANGULAR" "DIM" 3 "continuous" T)
   
7.           (list "DIMALIGNED" "DIM" 3 "continuous" T)
   
8.           (list "DIMBASELINE" "DIM" 3 "continuous" T)
   
9.           (list "DIMCENTER" "DIM" 3 "continuous" T)
   
10.           (list "DIMCONTINUE" "DIM" 3 "continuous" T)
    
11.           (list "DIMDIAMETER" "DIM" 3 "continuous" T)
    
12.           (list "DIMLINEAR" "DIM" 3 "continuous" T)
    
13.           (list "DIMORDINATE" "DIM" 3 "continuous" T)
    
14.           (list "DIMRADIUS" "DIM" 3 "continuous" T)
    
15.           (list "QDIM" "DIM" 3 "continuous" T)
    
16.           (list "QLEADER" "DIM" 3 "continuous" T)
    
17.           (list "DTEXT" "TXT" 3 "continuous" T)
    
18.           (list "MTEXT" "TXT" 3 "continuous" T)
    
19.           (list "TEXT" "TXT" 3 "continuous" T)
    
20.          ;(list "BHATCH" "填充" 9 "continuous" T)
    
21.          ;(list "HATCH" "填充" 9 "continuous" T)
    
22.          ;(list "POINT" "点" 4 "continuous" T)
    
23.          ;(list "XLINE" "辅助线" 8 "continuous" T)
    
24.          ;(list "LINE" "0" NIL "continuous" T)
    
25.          ;(list "XREF" "引用" 7 "continuous" T)
    
26.          ;(list "pline" "多义线" 2 "center" T)
    
27.     )
    
28.   )
    
29.   (setq OldLayer nil)
    
30.   (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
    
31.   (mapcar '(lambda (x) (vlr-command-reactor nil x))
    
32.     (list  '((:vlr-commandWillStart . xlr-start))
    
33.     '((:vlr-commandEnded . xlr-end))
    
34.     '((:vlr-commandCancelled . xlr-cancel))
    
35.     )
    
36.   )
    
37.   (vlr-editor-reactor nil '((:vlr-commandwillstart . xlr-edit)))
    
38. )
    
39. ;;;----------------------------------------------------------------------------;;;
    
40. (defun xlr-edit  (call callback / n)
    
41.   (foreach n *laylst
    
42.     (if  (= (strcase (car callback)) (strcase (car n)))
    
43.       (apply 'xsetlays (cdr n))
    
44.     )
    
45.   )
    
46. )
    
47. ;;;----------------------------------------------------------------------------;;;
    
48. (defun xlr-start (calling-reactor xlr-startinfo / n)
    
49.   (foreach n *laylst
    
50.     (if (= (strcase (car xlr-startinfo)) (strcase (car n)))  
    
51.       (apply 'xsetlays (cdr n))
    
52.     )
    
53.   )
    
54. )
    
55. ;;;----------------------------------------------------------------------------;;;
    
56. (defun xlr-end (calling-reactor xlr-endinfo / cmd)
    
57.   (setq cmd (car xlr-endinfo))
    
58.   (if (member cmd *cmdlst)
    
59.     (if (/= oldlayer nil)
    
60.       (progn
    
61.         (setvar "clayer" oldlayer)
    
62.         (setq oldlayer nil)
    
63.       )
    
64.     )
    
65.   )
    
66. )
    
67. ;;;----------------------------------------------------------------------------;;;
    
68. (defun xlr-cancel (calling-reactor xlr-cancelinfo / cmd)
    
69.   (setq cmd (car xlr-cancelinfo))
    
70.   (if (member cmd *cmdlst)
    
71.     (if (/= oldlayer nil)
    
72.       (progn
    
73.         (setvar "clayer" oldlayer)
    
74.         (setq oldlayer nil)
    
75.       )
    
76.     )
    
77.   )
    
78. )
    
79. ;;;----------------------------------------------------------------------------;;;
    
80. ;;;----------------------------------------------------------------------------;;;
    
81. (defun xsetlays  (lay-nam color ltype plotk / layobj ltypesobj)
    
82.   (defun layeron (layername / layerdata)
    
83.     (setq layerdata (entget (tblobjname "LAYER" layername)))
    
84.     (if (< (cdr (assoc 62 layerdata)) 0)
    
85.       (progn
    
86.         (setq layerdata (subst
    
87.                           (cons 62 (- 0 (cdr (assoc 62 layerdata))))
    
88.                           (assoc 62 layerdata)
    
89.                           layerdata
    
90.                         )
    
91.         )
    
92.         (entmod layerdata)
    
93.       )
    
94.     )
    
95.   )
    
96.   (if (tblobjname "layer" lay-nam)
    
97.     (progn
    
98.       (if (/= (strcase (getvar "clayer")) (strcase lay-nam))
    
99.         (setq oldlayer (getvar "clayer"))
    
100.         (progn
     
101.           (if (= oldlayer nil)
     
102.             (setq oldlayer lay-nam)
     
103.           )
     
104.         )
     
105.       )
     
106.       (layeron lay-nam)
     
107.       (setvar "clayer" lay-nam)
     
108.     )
     
109.     (progn
     
110.       (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list *lays lay-nam)))
     
111.       (setq layobj (vla-item *lays lay-nam))
     
112.       (if (not (tblobjname "ltype" ltype)) ;添加线型.
     
113.         (progn
     
114.           (setq ltypesobj (vla-get-linetypes *doc))
     
115.           (vla-load ltypesobj ltype (findfile "acad.lin"))  ;>>>　要加强，在多个*.lin寻找
     
116.           (vlax-release-object ltypesobj)
     
117.         )
     
118.       )
     
119.       (vla-put-layeron layobj :vlax-true)
     
120.       (vla-put-lock layobj :vlax-false)
     
121.       (if (= (strcase (getvar "clayer")) (command "layer" "on" "" "")(strcase lay-nam)) ;解冻.
     
122.         (vla-put-freeze layobj :vlax-false)
     
123.       )
     
124.       (vla-put-color layobj color)
     
125.       (vla-put-linetype layobj LTYPE)
     
126.       (vla-put-plottable layobj (if plotk :vlax-true :vlax-false))
     
127.     )
     
128.   )
     
129. )
     
130. (xlr-autolayer)        ;加载启动!
     

(defun xlr-autolayer ()<br />   ;; 图层初始化列表 内容：commands layers color linetype plottable<br />   (setq *doc (vla-get-activedocument (vlax-get-acad-object)))<br />   (setq *lays (vla-get-layers *doc))<br />   (setq  *laylst <br />     (list (list "DIMANGULAR" "DIM" 3 "continuous" T)<br />           (list "DIMALIGNED" "DIM" 3 "continuous" T)<br />           (list "DIMBASELINE" "DIM" 3 "continuous" T)<br />           (list "DIMCENTER" "DIM" 3 "continuous" T)<br />           (list "DIMCONTINUE" "DIM" 3 "continuous" T)<br />           (list "DIMDIAMETER" "DIM" 3 "continuous" T)<br />           (list "DIMLINEAR" "DIM" 3 "continuous" T)<br />           (list "DIMORDINATE" "DIM" 3 "continuous" T)<br />           (list "DIMRADIUS" "DIM" 3 "continuous" T)<br />           (list "QDIM" "DIM" 3 "continuous" T)<br />           (list "QLEADER" "DIM" 3 "continuous" T)<br />           (list "DTEXT" "TXT" 3 "continuous" T)<br />           (list "MTEXT" "TXT" 3 "continuous" T)<br />           (list "TEXT" "TXT" 3 "continuous" T)<br />          ;(list "BHATCH" "填充" 9 "continuous" T)<br />          ;(list "HATCH" "填充" 9 "continuous" T)<br />          ;(list "POINT" "点" 4 "continuous" T)<br />          ;(list "XLINE" "辅助线" 8 "continuous" T)<br />          ;(list "LINE" "0" NIL "continuous" T)<br />          ;(list "XREF" "引用" 7 "continuous" T)<br />          ;(list "pline" "多义线" 2 "center" T)<br />     )<br />   )<br />   (setq OldLayer nil)<br />   (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))<br />   (mapcar '(lambda (x) (vlr-command-reactor nil x))<br />     (list  '((:vlr-commandWillStart . xlr-start))<br />     '((:vlr-commandEnded . xlr-end))<br />     '((:vlr-commandCancelled . xlr-cancel))<br />     )<br />   )<br />   (vlr-editor-reactor nil '((:vlr-commandwillstart . xlr-edit)))<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-edit  (call callback / n)<br />   (foreach n *laylst<br />     (if  (= (strcase (car callback)) (strcase (car n)))<br />       (apply 'xsetlays (cdr n))<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-start (calling-reactor xlr-startinfo / n)<br />   (foreach n *laylst<br />     (if (= (strcase (car xlr-startinfo)) (strcase (car n)))  <br />       (apply 'xsetlays (cdr n))<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-end (calling-reactor xlr-endinfo / cmd)<br />   (setq cmd (car xlr-endinfo))<br />   (if (member cmd *cmdlst)<br />     (if (/= oldlayer nil)<br />       (progn <br />         (setvar "clayer" oldlayer)<br />         (setq oldlayer nil)<br />       )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xlr-cancel (calling-reactor xlr-cancelinfo / cmd)<br />   (setq cmd (car xlr-cancelinfo))<br />   (if (member cmd *cmdlst)<br />     (if (/= oldlayer nil)<br />       (progn <br />         (setvar "clayer" oldlayer)<br />         (setq oldlayer nil)<br />       )<br />     )<br />   )<br /> )<br /> ;;;----------------------------------------------------------------------------;;;<br /> ;;;----------------------------------------------------------------------------;;;<br /> (defun xsetlays  (lay-nam color ltype plotk / layobj ltypesobj)<br />   (defun layeron (layername / layerdata)<br />     (setq layerdata (entget (tblobjname "LAYER" layername)))<br />     (if (< (cdr (assoc 62 layerdata)) 0)<br />       (progn<br />         (setq layerdata (subst<br />                           (cons 62 (- 0 (cdr (assoc 62 layerdata))))<br />                           (assoc 62 layerdata)<br />                           layerdata<br />                         )<br />         )<br />         (entmod layerdata)<br />       )<br />     )<br />   )<br />   (if (tblobjname "layer" lay-nam)<br />     (progn<br />       (if (/= (strcase (getvar "clayer")) (strcase lay-nam))<br />         (setq oldlayer (getvar "clayer"))<br />         (progn<br />           (if (= oldlayer nil)<br />             (setq oldlayer lay-nam)<br />           )<br />         )<br />       )<br />       (layeron lay-nam)<br />       (setvar "clayer" lay-nam)<br />     )<br />     (progn<br />       (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list *lays lay-nam)))<br />       (setq layobj (vla-item *lays lay-nam))<br />       (if (not (tblobjname "ltype" ltype)) ;添加线型.<br />         (progn<br />           (setq ltypesobj (vla-get-linetypes *doc))<br />           (vla-load ltypesobj ltype (findfile "acad.lin"))  ;>>>　要加强，在多个*.lin寻找<br />           (vlax-release-object ltypesobj)<br />         )<br />       )<br />       (vla-put-layeron layobj :vlax-true)<br />       (vla-put-lock layobj :vlax-false)<br />       (if (= (strcase (getvar "clayer")) (command "layer" "on" "" "")(strcase lay-nam)) ;解冻.<br />         (vla-put-freeze layobj :vlax-false)<br />       )<br />       (vla-put-color layobj color)<br />       (vla-put-linetype layobj LTYPE)<br />       (vla-put-plottable layobj (if plotk :vlax-true :vlax-false))<br />     )<br />   )<br /> )<br /> (xlr-autolayer)        ;加载启动!<br />

试下这个如何.

yxl88168

回复 SunSpring 的帖子

谢谢楼主，这个非常好用

xjf

         是龙版主的Autolayer差不多的吧

自贡黄明儒

SunSpring 发表于 2011-5-11 20:37
试下这个如何.

我写了几句插入时间的程序，用了你的自动图层后，系统就崩溃了。
;插入时间
(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)
)

啵浪鼓

挺好的反应器
解冻/解锁
(if (/= (cdr (assoc 70 layerdata)) 0)
      (progn
        (setq layerdata (subst
                          (cons 70 0)
                          (assoc 70 layerdata)
                          layerdata
                        )
        )
        (entmod layerdata)
      )
    )