[求助]关于cad标注的问题

gjliang

大家好，我有个想法，就是当选择标注进行标注后，跟着直接新建一个标注的层。调试了一下，好象没任何反映，是不是程序执行完ThisDrawing.SendCommand "_dimaligned" & vbCr就退出了
请大家帮助解决这个问题，程序如下：
Sub a()
Dim layer1 As AcadLayer
Set layer1 = ThisDrawing.Layers.add("标注")
layer1.Color = acGreen
Dim n As Integer
ThisDrawing.SendCommand "_dimaligned" & vbCr
For Each ent In ThisDrawing.ModelSpace
If TypeOf ent Is AcadDimAligned Then
ent.Layer = "标注"
End If
Next
End Sub

BUBUBA918

mccad 发表于 2003-6-10 17:29
链接地址：
http://www.mjtd.com/mcdown/list.asp?id=370

能否重新提供下载，现在无链接了

zfbj

（1）未定义ent对象。
    （2）引入SendCommand命令引起了程序执行顺序的混乱，后面的循环语句并不是没有执行，而是在SendCommand之前执行！
    我的建议是，不用SendCommand函数，而是要求用户输入数据，根据数据自动创建一个标注对象。
    第（2）条是我测试的结果，可能会有不妥之处。

mccad

你所需要的方法就是在标注时把标注对象放到指定的标注图层中，可以使用事件来解决。
但使用事件有一个缺点就是当标注时按了取消键时不能回复先前的图层。
或者可以这样：
在开始命令的事件中记下当前空间的对象数量，然后在结束命令的事件中写入判断刚才的命令是否为标注命令，如果是标注命令则从当前空间对象数量后的对象开始判断对象是否为标注对象，如果是则改变其图层。

这样做就也就是在开始命令时不对图层进行切换，而是在对象建立后再改对象的图层，所以标注时对象还是在当前图层中，而标注完成后才会把对象放到指定的图层中。
为什么不直接判断最后建立的对象来切换呢，因为有些标注命令可以建立多个标注对象，如连接标注，所以只判断最后一个命令是不正确的。
希望大家能用这个思路写出一个程序出来供大家使用(我也想用)。

mccad

注意程序只考虑了新建图层，而没有考虑新图层的颜色及线型等其它属性，大家可以自己添加上去。
程序有一个好处就是等所有对象添加后才改变对象的图层，所以按了ESC键也没关系，不会造成当前图层换成其它图层的问题。
有一个缺点：在使用连接标注时如果按了取消，则已经创建的标注对象不能改图层。

2. 
   
3. Public EntCount As Integer
   
4. 
   
5. Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
   
6.    EntCount = ThisDrawing.ModelSpace.Count
   
7.    
   
8. End Sub
   
9. 
   
10. Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
    
11.     If Left(UCase(CommandName), 3) = "DIM" Then
    
12.         Dim NewEnt As AcadEntity
    
13.         Dim i As Integer
    
14.         Dim NewLayerName As String
    
15.         '以下定义了要将标注对象移动到的图层名称
    
16.         NewLayerName = "3"
    
17.         CreateLayer ("NewLayerName")
    
18.         For i = EntCount To ThisDrawing.ModelSpace.Count - 1
    
19.         Set NewEnt = ThisDrawing.ModelSpace.Item(i)
    
20.         NewEnt.Layer = "NewLayerName"
    
21.         Next
    
22.     End If
    
23. End Sub
    
24. 
    
25. Public Function CreateLayer(ssLayerName As String) As AcadLayer
    
26. On Error Resume Next
    
27.     Set CreateLayer = ThisDrawing.Layers(ssLayerName)
    
28.     If Err Then
    
29.         Err.Clear
    
30.         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
    
31.     End If
    
32. 
    
33. End Function
    

<br /> Public EntCount As Integer<br /> <br /> Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)<br />    EntCount = ThisDrawing.ModelSpace.Count<br />    <br /> End Sub<br /> <br /> Private Sub AcadDocument_EndCommand(ByVal CommandName As String)<br />     If Left(UCase(CommandName), 3) = "DIM" Then<br />         Dim NewEnt As AcadEntity<br />         Dim i As Integer<br />         Dim NewLayerName As String<br />         '以下定义了要将标注对象移动到的图层名称<br />         NewLayerName = "3"<br />         CreateLayer ("NewLayerName")<br />         For i = EntCount To ThisDrawing.ModelSpace.Count - 1<br />         Set NewEnt = ThisDrawing.ModelSpace.Item(i)<br />         NewEnt.Layer = "NewLayerName"<br />         Next<br />     End If<br /> End Sub<br /> <br /> Public Function CreateLayer(ssLayerName As String) As AcadLayer<br /> On Error Resume Next<br />     Set CreateLayer = ThisDrawing.Layers(ssLayerName)<br />     If Err Then<br />         Err.Clear<br />         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)<br />     End If<br /> <br /> End Function<br />

mccad

程序利用注册表来保存切换的图层配置，现在还未完成生成注册表部分，大家可以把以下文件导入到注册表中先试试吧：


注意以下程序下载：

以下是程序内容：

2. ' AutoLayer.dvb
   
3. Public EntCount As Integer
   
4. Public LayerSet As Variant
   
5. Public GetReg As Boolean
   
6. 
   
7. Private Sub AutoLayerLoad()
   
8.     Dim LayerSetting() As String
   
9.     Dim SplitSetting As Variant
   
10.     Dim LayerName As Variant
    
11.     Dim LayerCount As Integer
    
12.     LayerName = GetAllSettings("MCCAD", "AutoLayer")
    
13.     For LayerCount = LBound(LayerName, 1) To UBound(LayerName, 1)
    
14.         ReDim Preserve LayerSetting(2, LayerCount)
    
15.         LayerSetting(0, LayerCount) = LayerName(LayerCount, 0)
    
16.         SplitSetting = Split(LayerName(LayerCount, 1), ",")
    
17.         LayerSetting(1, LayerCount) = SplitSetting(0)
    
18.         LayerSetting(2, LayerCount) = SplitSetting(1)
    
19.     Next
    
20.         LayerSet = LayerSetting()
    
21. End Sub
    
22. Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
    
23.    EntCount = ThisDrawing.ModelSpace.Count
    
24. End Sub
    
25. 
    
26. Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
    
27.    If GetReg = False Then
    
28.         AutoLayerLoad
    
29.         GetReg = True
    
30.    End If
    
31.    Dim NewEnt As AcadEntity
    
32.    Dim i As Integer
    
33.    Dim NewLayerName As String
    
34.    Dim j As Integer
    
35.    Dim NewLayerColor As Integer
    
36.    For j = LBound(LayerSet, 2) To UBound(LayerSet, 2)
    
37.        If UCase(CommandName) Like LayerSet(0, j) Then
    
38.            NewLayerName = LayerSet(1, j)
    
39.            NewLayerColor = CVar(LayerSet(2, j))
    
40.            CreateLayer NewLayerName, NewLayerColor
    
41.            If ThisDrawing.ModelSpace.Count > EntCount Then
    
42.                For i = EntCount To ThisDrawing.ModelSpace.Count - 1
    
43.                    Set NewEnt = ThisDrawing.ModelSpace.Item(i)
    
44.                    NewEnt.Layer = NewLayerName
    
45.                Next
    
46.            End If
    
47.            Exit For
    
48.        End If
    
49.    Next
    
50. End Sub
    
51. 
    
52. Public Function CreateLayer(ssLayerName As String, Optional EntColor As Integer) As AcadLayer
    
53. On Error Resume Next
    
54.     Set CreateLayer = ThisDrawing.Layers(ssLayerName)
    
55.     If Err Then
    
56.         Err.Clear
    
57.         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
    
58.         If EntColor <> 0 Then CreateLayer.color = EntColor
    
59.     End If
    
60. End Function
    

' AutoLayer.dvb<br /> Public EntCount As Integer<br /> Public LayerSet As Variant<br /> Public GetReg As Boolean<br /> <br /> Private Sub AutoLayerLoad()<br />     Dim LayerSetting() As String<br />     Dim SplitSetting As Variant<br />     Dim LayerName As Variant<br />     Dim LayerCount As Integer<br />     LayerName = GetAllSettings("MCCAD", "AutoLayer")<br />     For LayerCount = LBound(LayerName, 1) To UBound(LayerName, 1)<br />         ReDim Preserve LayerSetting(2, LayerCount)<br />         LayerSetting(0, LayerCount) = LayerName(LayerCount, 0)<br />         SplitSetting = Split(LayerName(LayerCount, 1), ",")<br />         LayerSetting(1, LayerCount) = SplitSetting(0)<br />         LayerSetting(2, LayerCount) = SplitSetting(1)<br />     Next<br />         LayerSet = LayerSetting()<br /> End Sub<br /> Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)<br />    EntCount = ThisDrawing.ModelSpace.Count<br /> End Sub<br /> <br /> Private Sub AcadDocument_EndCommand(ByVal CommandName As String)<br />    If GetReg = False Then<br />         AutoLayerLoad<br />         GetReg = True<br />    End If<br />    Dim NewEnt As AcadEntity<br />    Dim i As Integer<br />    Dim NewLayerName As String<br />    Dim j As Integer<br />    Dim NewLayerColor As Integer<br />    For j = LBound(LayerSet, 2) To UBound(LayerSet, 2)<br />        If UCase(CommandName) Like LayerSet(0, j) Then<br />            NewLayerName = LayerSet(1, j)<br />            NewLayerColor = CVar(LayerSet(2, j))<br />            CreateLayer NewLayerName, NewLayerColor<br />            If ThisDrawing.ModelSpace.Count > EntCount Then<br />                For i = EntCount To ThisDrawing.ModelSpace.Count - 1<br />                    Set NewEnt = ThisDrawing.ModelSpace.Item(i)<br />                    NewEnt.Layer = NewLayerName<br />                Next<br />            End If<br />            Exit For<br />        End If<br />    Next<br /> End Sub<br /> <br /> Public Function CreateLayer(ssLayerName As String, Optional EntColor As Integer) As AcadLayer<br /> On Error Resume Next<br />     Set CreateLayer = ThisDrawing.Layers(ssLayerName)<br />     If Err Then<br />         Err.Clear<br />         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)<br />         If EntColor <> 0 Then CreateLayer.color = EntColor<br />     End If<br /> End Function<br />

gjliang

谢谢了，明老大的程序让我受益菲浅,因为是

mccad

链接地址：
http://www.mjtd.com/mcdown/list.asp?id=370

HQ_2003

mccad

zzlzz

斑竹做的东西真的是专业，学习学习。