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

gjliang · 发表于 2003-6-3 21:08:00

大家好，我有个想法，就是当选择标注进行标注后，跟着直接新建一个标注的层。调试了一下，好象没任何反映，是不是程序执行完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 · 发表于 2022-7-13 20:59:00

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

zfbj · 发表于 2003-6-4 13:12:00

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

mccad · 发表于 2003-6-5 20:07:00

你所需要的方法就是在标注时把标注对象放到指定的标注图层中，可以使用事件来解决。
但使用事件有一个缺点就是当标注时按了取消键时不能回复先前的图层。
或者可以这样：
在开始命令的事件中记下当前空间的对象数量，然后在结束命令的事件中写入判断刚才的命令是否为标注命令，如果是标注命令则从当前空间对象数量后的对象开始判断对象是否为标注对象，如果是则改变其图层。
这样做就也就是在开始命令时不对图层进行切换，而是在对象建立后再改对象的图层，所以标注时对象还是在当前图层中，而标注完成后才会把对象放到指定的图层中。
为什么不直接判断最后建立的对象来切换呢，因为有些标注命令可以建立多个标注对象，如连接标注，所以只判断最后一个命令是不正确的。
希望大家能用这个思路写出一个程序出来供大家使用(我也想用)。

mccad · 发表于 2003-6-5 20:49:00

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

copy


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

mccad · 发表于 2003-6-6 18:27:00

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

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:g53lertzxa0.rar
下载次数:0 文件大小:276 Bytes 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

注意以下程序下载：

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:dvjydoflocx.dvb
下载次数:0 文件大小:48 KB 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

以下是程序内容：

copy


' 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 EntColor  0 Then CreateLayer.color = EntColor
    End If
End Function