[求助]关于cad标注的问题
大家好，我有个想法，就是当选择标注进行标注后，跟着直接新建一个标注的层。调试了一下，好象没任何反映，是不是程序执行完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
能否重新提供下载，现在无链接了 （1）未定义ent对象。
（2）引入SendCommand命令引起了程序执行顺序的混乱，后面的循环语句并不是没有执行，而是在SendCommand之前执行！
我的建议是，不用SendCommand函数，而是要求用户输入数据，根据数据自动创建一个标注对象。
第（2）条是我测试的结果，可能会有不妥之处。 你所需要的方法就是在标注时把标注对象放到指定的标注图层中，可以使用事件来解决。
但使用事件有一个缺点就是当标注时按了取消键时不能回复先前的图层。
或者可以这样：
在开始命令的事件中记下当前空间的对象数量，然后在结束命令的事件中写入判断刚才的命令是否为标注命令，如果是标注命令则从当前空间对象数量后的对象开始判断对象是否为标注对象，如果是则改变其图层。
这样做就也就是在开始命令时不对图层进行切换，而是在对象建立后再改对象的图层，所以标注时对象还是在当前图层中，而标注完成后才会把对象放到指定的图层中。
为什么不直接判断最后建立的对象来切换呢，因为有些标注命令可以建立多个标注对象，如连接标注，所以只判断最后一个命令是不正确的。
希望大家能用这个思路写出一个程序出来供大家使用(我也想用)。 注意程序只考虑了新建图层，而没有考虑新图层的颜色及线型等其它属性，大家可以自己添加上去。
程序有一个好处就是等所有对象添加后才改变对象的图层，所以按了ESC键也没关系，不会造成当前图层换成其它图层的问题。
有一个缺点：在使用连接标注时如果按了取消，则已经创建的标注对象不能改图层。
Public EntCount As Integer
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
EntCount = ThisDrawing.ModelSpace.Count
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If Left(UCase(CommandName), 3) = "DIM" Then
Dim NewEnt As AcadEntity
Dim i As Integer
Dim NewLayerName As String
'以下定义了要将标注对象移动到的图层名称
NewLayerName = "3"
CreateLayer ("NewLayerName")
For i = EntCount To ThisDrawing.ModelSpace.Count - 1
Set NewEnt = ThisDrawing.ModelSpace.Item(i)
NewEnt.Layer = "NewLayerName"
Next
End If
End Sub
Public Function CreateLayer(ssLayerName As String) As AcadLayer
On Error Resume Next
Set CreateLayer = ThisDrawing.Layers(ssLayerName)
If Err Then
Err.Clear
Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
End If
End Function
程序利用注册表来保存切换的图层配置，现在还未完成生成注册表部分，大家可以把以下文件导入到注册表中先试试吧：
注意以下程序下载：
以下是程序内容：
' AutoLayer.dvb
Public EntCount As Integer
Public LayerSet As Variant
Public GetReg As Boolean
Private Sub AutoLayerLoad()
Dim LayerSetting() As String
Dim SplitSetting As Variant
Dim LayerName As Variant
Dim LayerCount As Integer
LayerName = GetAllSettings("MCCAD", "AutoLayer")
For LayerCount = LBound(LayerName, 1) To UBound(LayerName, 1)
ReDim Preserve LayerSetting(2, LayerCount)
LayerSetting(0, LayerCount) = LayerName(LayerCount, 0)
SplitSetting = Split(LayerName(LayerCount, 1), ",")
LayerSetting(1, LayerCount) = SplitSetting(0)
LayerSetting(2, LayerCount) = SplitSetting(1)
Next
LayerSet = LayerSetting()
End Sub
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
EntCount = ThisDrawing.ModelSpace.Count
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If GetReg = False Then
AutoLayerLoad
GetReg = True
End If
Dim NewEnt As AcadEntity
Dim i As Integer
Dim NewLayerName As String
Dim j As Integer
Dim NewLayerColor As Integer
For j = LBound(LayerSet, 2) To UBound(LayerSet, 2)
If UCase(CommandName) Like LayerSet(0, j) Then
NewLayerName = LayerSet(1, j)
NewLayerColor = CVar(LayerSet(2, j))
CreateLayer NewLayerName, NewLayerColor
If ThisDrawing.ModelSpace.Count > EntCount Then
For i = EntCount To ThisDrawing.ModelSpace.Count - 1
Set NewEnt = ThisDrawing.ModelSpace.Item(i)
NewEnt.Layer = NewLayerName
Next
End If
Exit For
End If
Next
End Sub
Public Function CreateLayer(ssLayerName As String, Optional EntColor As Integer) As AcadLayer
On Error Resume Next
Set CreateLayer = ThisDrawing.Layers(ssLayerName)
If Err Then
Err.Clear
Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
If EntColor0 Then CreateLayer.color = EntColor
End If
End Function
谢谢了，明老大的程序让我受益菲浅,因为是 链接地址：
http://www.mjtd.com/mcdown/list.asp?id=370
斑竹做的东西真的是专业，学习学习。
页:
[1]