[讨论]：关于实现标注的问题

gjliang

大家好，我有个想法，就是当选择标注进行标注后，跟着直接新建一个标注的层。
我用vba写了这个程序，但运行后达不到象cad里那样的标注效果，就是在确定尺寸界线的长度时并不能实现象cad里那样尺寸线和标注文字随着光标移动。请大家帮助解决这个问题，程序如下：
Sub dli()
Dim dli As AcadDimAligned
Dim pt1 As Variant
Dim pt2 As Variant
Dim pt3 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "startpt")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "endpt")
pt3 = ThisDrawing.Utility.GetPoint(pt2, "textpt")
Set dli = ThisDrawing.ModelSpace.AddDimAligned(pt1, pt2, pt3)
Dim layer1 As AcadLayer
Set layer1 = ThisDrawing.Layers.Add("标注")
layer1.Color = acGreen
dli.Layer = "标注"
End Sub

efan2000

如果不调用CAD的内部命令，那就只能使用第三方的程序，或者自己使用系统的API来控制。

gjliang

我是在学这方面的问题，如果调用cad的命令，请问具体怎样操作。

efan2000

以下是我尝试的，将鼠标依次定位到直线的两个端点，由于像素是整数，因而会形成误差。

2. 
   
3.   [FONT=courier new]
   
4. '将像素转换成ACAD的当前图形单位。
   
5. Function PixelsToAcadUnit(ByVal Pixels As Integer) As Double
   
6.     Dim ViewSize As Double
   
7.     ViewSize = acadDoc.GetVariable("VIEWSIZE")
   
8.     Dim ScreenSize As Variant
   
9.     ScreenSize = acadDoc.GetVariable("SCREENSIZE")
   
10.     PixelsToAcadUnit = Pixels * ViewSize / ScreenSize(1)
    
11. End Function
    
12. 
    
13. '将ACAD的当前图形单位转换成像素。
    
14. Function AcadUnitToPixels(ByVal AcadUnit As Double) As Double
    
15.     Dim ViewSize As Double
    
16.     ViewSize = acadDoc.GetVariable("VIEWSIZE")
    
17.     Dim ScreenSize As Variant
    
18.     ScreenSize = acadDoc.GetVariable("SCREENSIZE")
    
19.     AcadUnitToPixels = AcadUnit * ScreenSize(1) / ViewSize
    
20. End Function
    
21. 
    
22. '将ACAD中的某一点坐标转换到屏幕上的某一像素位置。
    
23. Private Function AcadCoordToPixels(ByVal AcadCoord As Variant) As POINTAPI
    
24.     Dim ViewCtr As Variant
    
25.     ViewCtr = acadDoc.GetVariable("VIEWCTR")
    
26.     Dim ScreenSize As Variant
    
27.     ScreenSize = acadDoc.GetVariable("SCREENSIZE")
    
28.     Dim p As POINTAPI
    
29.     Debug.Print AcadUnitToPixels(AcadCoord(0) - ViewCtr(0))
    
30.     p.X = Round(ScreenSize(0) / 2 + AcadUnitToPixels(AcadCoord(0) - ViewCtr(0)), 0)
    
31.     p.Y = Round(ScreenSize(1) / 2 - AcadUnitToPixels(AcadCoord(1) - ViewCtr(1)), 0)
    
32.     Dim lRet As Long
    
33.     lRet = ClientToScreen(acadDoc.hWnd, p)
    
34.     AcadCoordToPixels = p
    
35. End Function
    
36. 
    
37. 
    
38. 
    
39. Option Explicit
    
40. Private Type POINTAPI
    
41.     X As Long
    
42.     Y As Long
    
43. End Type
    
44. Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    
45. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    
46. Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    
47. 
    
48. Dim acadApp As AcadApplication
    
49. Dim acadDoc As AcadDocument
    
50. 
    
51. Sub test()
    
52.     Set acadApp = GetObject(, "AutoCAD.Application")
    
53.     acadApp.Visible = True
    
54.     Set acadDoc = acadApp.ActiveDocument
    
55.     AppActivate acadApp.Caption
    
56.     Dim p1 As POINTAPI
    
57.     p1 = AcadCoordToPixels(acadDoc.ModelSpace(0).StartPoint)
    
58.     Dim p2 As POINTAPI
    
59.     p2 = AcadCoordToPixels(acadDoc.ModelSpace(0).EndPoint)
    
60.     Sleep 1000
    
61.     SetCursorPos p1.X, p1.Y
    
62.     Sleep 1000
    
63.     SetCursorPos p2.X, p2.Y
    
64. End Sub
    
65. 
    
66.   [/FONT]
    

<br />   [FONT=courier new]<br /> '将像素转换成ACAD的当前图形单位。<br /> Function PixelsToAcadUnit(ByVal Pixels As Integer) As Double<br />     Dim ViewSize As Double<br />     ViewSize = acadDoc.GetVariable("VIEWSIZE")<br />     Dim ScreenSize As Variant<br />     ScreenSize = acadDoc.GetVariable("SCREENSIZE")<br />     PixelsToAcadUnit = Pixels * ViewSize / ScreenSize(1)<br /> End Function<br /> <br /> '将ACAD的当前图形单位转换成像素。<br /> Function AcadUnitToPixels(ByVal AcadUnit As Double) As Double<br />     Dim ViewSize As Double<br />     ViewSize = acadDoc.GetVariable("VIEWSIZE")<br />     Dim ScreenSize As Variant<br />     ScreenSize = acadDoc.GetVariable("SCREENSIZE")<br />     AcadUnitToPixels = AcadUnit * ScreenSize(1) / ViewSize<br /> End Function<br /> <br /> '将ACAD中的某一点坐标转换到屏幕上的某一像素位置。<br /> Private Function AcadCoordToPixels(ByVal AcadCoord As Variant) As POINTAPI<br />     Dim ViewCtr As Variant<br />     ViewCtr = acadDoc.GetVariable("VIEWCTR")<br />     Dim ScreenSize As Variant<br />     ScreenSize = acadDoc.GetVariable("SCREENSIZE")<br />     Dim p As POINTAPI<br />     Debug.Print AcadUnitToPixels(AcadCoord(0) - ViewCtr(0))<br />     p.X = Round(ScreenSize(0) / 2 + AcadUnitToPixels(AcadCoord(0) - ViewCtr(0)), 0)<br />     p.Y = Round(ScreenSize(1) / 2 - AcadUnitToPixels(AcadCoord(1) - ViewCtr(1)), 0)<br />     Dim lRet As Long<br />     lRet = ClientToScreen(acadDoc.hWnd, p)<br />     AcadCoordToPixels = p<br /> End Function<br /> <br /> <br /> <br /> Option Explicit<br /> Private Type POINTAPI<br />     X As Long<br />     Y As Long<br /> End Type<br /> Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long<br /> Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)<br /> Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long<br /> <br /> Dim acadApp As AcadApplication<br /> Dim acadDoc As AcadDocument<br /> <br /> Sub test()<br />     Set acadApp = GetObject(, "AutoCAD.Application")<br />     acadApp.Visible = True<br />     Set acadDoc = acadApp.ActiveDocument<br />     AppActivate acadApp.Caption<br />     Dim p1 As POINTAPI<br />     p1 = AcadCoordToPixels(acadDoc.ModelSpace(0).StartPoint)<br />     Dim p2 As POINTAPI<br />     p2 = AcadCoordToPixels(acadDoc.ModelSpace(0).EndPoint)<br />     Sleep 1000<br />     SetCursorPos p1.X, p1.Y<br />     Sleep 1000<br />     SetCursorPos p2.X, p2.Y<br /> End Sub<br /> <br />   [/FONT]<br />

gjliang

是在vb下编写的吧，好象很烦琐啊，能不能象你所说的调用cad内部的命令，然后用程序得到最后的标注对象，然后给它指定层呢。那怎样给参数赋值呢？

efan2000

首先保存模型空间中的实体数目，接着使用SendCommand，发送"_dimaligned"命令，调用对齐标注命令，等运行完之后，再检查模型空间中的实体数目，如果是上一次的值加1，表示操作成功，那么引用最后一个实体，修改它的层属性和颜色属性。
如：

2. 
   
3.   [FONT=courier new]
   
4. Sub test()
   
5.     Dim n As Integer
   
6.     n = ThisDrawing.ModelSpace.Count
   
7.     ThisDrawing.SendCommand "_dimaligned" & vbCr
   
8.     If ThisDrawing.ModelSpace.Count = n + 1 Then
   
9.         ThisDrawing.ModelSpace(n).Layer = "标注"
   
10.         ThisDrawing.ModelSpace(n).Color = acGreen
    
11.     End If
    
12. End Sub[/FONT]
    

<br />   [FONT=courier new]<br /> Sub test()<br />     Dim n As Integer<br />     n = ThisDrawing.ModelSpace.Count<br />     ThisDrawing.SendCommand "_dimaligned" & vbCr<br />     If ThisDrawing.ModelSpace.Count = n + 1 Then<br />         ThisDrawing.ModelSpace(n).Layer = "标注"<br />         ThisDrawing.ModelSpace(n).Color = acGreen<br />     End If<br /> End Sub[/FONT]<br />

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

efan2000

查出原因了，是因为调用CAD的内部命令时是异步调用，即只是发送一个消息，而不会等候命令执行完再继续执行下一个语句，造成了标注还没完成，而语句就已经执行结束了。
只好改用事件来拭操作了，在开始命令和结束命令中操作。如下：

2. 
   
3.   [FONT=courier new]
   
4. Option Explicit
   
5. 
   
6. Dim n As Integer
   
7. 
   
8. Sub test()
   
9.     ThisDrawing.SendCommand "_dimaligned" & vbCr
   
10. End Sub
    
11. 
    
12. Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
    
13.     If CommandName = "DIMALIGNED" Then
    
14.         n = ThisDrawing.ModelSpace.Count
    
15.     End If
    
16. End Sub
    
17. 
    
18. Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
    
19.     If CommandName = "DIMALIGNED" Then
    
20.         If ThisDrawing.ModelSpace.Count = n + 1 Then
    
21.             ThisDrawing.ModelSpace(n).Layer = "标注"
    
22.             ThisDrawing.ModelSpace(n).Color = acGreen
    
23.         End If
    
24.     End If
    
25. End Sub
    
26.   [/FONT]
    

<br />   [FONT=courier new]<br /> Option Explicit<br /> <br /> Dim n As Integer<br /> <br /> Sub test()<br />     ThisDrawing.SendCommand "_dimaligned" & vbCr<br /> End Sub<br /> <br /> Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)<br />     If CommandName = "DIMALIGNED" Then<br />         n = ThisDrawing.ModelSpace.Count<br />     End If<br /> End Sub<br /> <br /> Private Sub AcadDocument_EndCommand(ByVal CommandName As String)<br />     If CommandName = "DIMALIGNED" Then<br />         If ThisDrawing.ModelSpace.Count = n + 1 Then<br />             ThisDrawing.ModelSpace(n).Layer = "标注"<br />             ThisDrawing.ModelSpace(n).Color = acGreen<br />         End If<br />     End If<br /> End Sub<br />   [/FONT]<br />

Laoyao

实现DIMENSION自动另居一层的一种方法。
在命令发送前对命令进行判断，如果含有“DIM”字样则改变ACTIVELAYER为DIM层，命令后再返回原层。
以下代码加入ThisDrawing

2. 
   
3.   [FONT=courier new]
   
4. Dim X1 As Class1
   
5. Sub StartDimensionMode()
   
6.     Set X1 = New Class1
   
7. End Sub
   
8. Sub EndDimensionMode()
   
9.     Set X1 = Nothing
   
10. End Sub
    
11. 
    
12.   [/FONT]
    

<br />   [FONT=courier new]<br /> Dim X1 As Class1<br /> Sub StartDimensionMode()<br />     Set X1 = New Class1<br /> End Sub<br /> Sub EndDimensionMode()<br />     Set X1 = Nothing<br /> End Sub<br /> <br />   [/FONT]<br />

新建CLASS MODULE--CLASS1
加入如下代码

2. 
   
3.   [FONT=courier new]
   
4. Public WithEvents App As AcadApplication
   
5. Dim curLayer As AcadLayer
   
6. Dim dimCommand As Boolean
   
7. Private Sub App_BeginCommand(ByVal CommandName As String)
   
8.     On Error Resume Next
   
9.     If InStr(UCase(CommandName), "DIM") Then
   
10.         Set curLayer = ActiveDocument.ActiveLayer
    
11.         ActiveDocument.ActiveLayer = getDimLayer
    
12.         dimCommand = True
    
13.     End If
    
14. End Sub
    
15. 
    
16. Private Sub App_EndCommand(ByVal CommandName As String)
    
17.     On Error GoTo errhandle
    
18.     If dimCommand Then
    
19.         ActiveDocument.ActiveLayer = curLayer
    
20.         dimCommand = False
    
21.     End If
    
22.     Exit Sub
    
23. errhandle:
    
24.     ActiveDocument.ActiveLayer = ActiveDocument.Layers(0)
    
25.     dimCommand = False
    
26. End Sub
    
27. 
    
28. Private Sub App_SysVarChanged(ByVal SysvarName As String, ByVal newVal As Variant)
    
29.    
    
30. End Sub
    
31. 
    
32. Private Sub Class_Initialize()
    
33.     Set App = AcadApplication
    
34. End Sub
    
35. Function getDimLayer() As AcadLayer
    
36.     Dim tLayer As AcadLayer
    
37.     Dim color As AcadAcCmColor
    
38.     Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    
39.     Call color.SetRGB(255, 0, 0)
    
40.      For Each tLayer In App.ActiveDocument.Layers
    
41.         If tLayer.Name = "DIMLayer" Then
    
42.             Set getDimLayer = tLayer
    
43.             Exit Function
    
44.         End If
    
45.     Next
    
46.     Set tLayer = App.ActiveDocument.Layers.Add("DIMLayer")
    
47.     tLayer.TrueColor = color
    
48.     Set getDimLayer = tLayer
    
49.    
    
50. End Function
    
51. 
    
52.   [/FONT]
    

<br />   [FONT=courier new]<br /> Public WithEvents App As AcadApplication<br /> Dim curLayer As AcadLayer<br /> Dim dimCommand As Boolean<br /> Private Sub App_BeginCommand(ByVal CommandName As String)<br />     On Error Resume Next<br />     If InStr(UCase(CommandName), "DIM") Then<br />         Set curLayer = ActiveDocument.ActiveLayer<br />         ActiveDocument.ActiveLayer = getDimLayer<br />         dimCommand = True<br />     End If<br /> End Sub<br /> <br /> Private Sub App_EndCommand(ByVal CommandName As String)<br />     On Error GoTo errhandle<br />     If dimCommand Then<br />         ActiveDocument.ActiveLayer = curLayer<br />         dimCommand = False<br />     End If<br />     Exit Sub<br /> errhandle:<br />     ActiveDocument.ActiveLayer = ActiveDocument.Layers(0)<br />     dimCommand = False<br /> End Sub<br /> <br /> Private Sub App_SysVarChanged(ByVal SysvarName As String, ByVal newVal As Variant)<br />     <br /> End Sub<br /> <br /> Private Sub Class_Initialize()<br />     Set App = AcadApplication<br /> End Sub<br /> Function getDimLayer() As AcadLayer<br />     Dim tLayer As AcadLayer<br />     Dim color As AcadAcCmColor<br />     Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")<br />     Call color.SetRGB(255, 0, 0)<br />      For Each tLayer In App.ActiveDocument.Layers<br />         If tLayer.Name = "DIMLayer" Then<br />             Set getDimLayer = tLayer<br />             Exit Function<br />         End If<br />     Next<br />     Set tLayer = App.ActiveDocument.Layers.Add("DIMLayer")<br />     tLayer.TrueColor = color<br />     Set getDimLayer = tLayer<br />     <br /> End Function<br /> <br />   [/FONT]<br />

gjliang

ok了，太感谢了，其实最重要的是通过这个例子使我明白事件操作的编程方法，这样的话，如果根据自己的实际需要，就可以把很多cad命令来进行扩充了。

efan2000

最初由 Laoyao 发布
[B]实现DIMENSION自动另居一层的一种方法。
在命令发送前对命令进行判断，如果含有“DIM”字样则改变ACTIVELAYER为DIM层，命令后再返回原层。
以下代码加入ThisDrawing
[CODE]
  
Dim X1 As Cla... [/B]

演示了类以及事件的使用，同时能够对R2004的真彩色功能进行应用，可供大家参考，欢迎能够常来。

在R2004中，每一个实体都可以使用真彩色的功能，它将原来的Color属性（整型）变更为TrueColor属性（Color对象）。

Laoyao

因为不会对DIMENSION OBJECT使用WITHEVENTS，所以只能在APPLICATION中判断。
请问版主，如何对DIMENSION OBJECT使用WITHEVENTS

efan2000

关于对象的事件有两种，一种是文档中的事件，它提供了当对象增加、修改和删除时触发的事件。另一种是对象本身的修改事件，它是对象创建之后进行修改时触发的事件。
对于上面的问题，应该使用文档级的事件，在事件触发的过程当中首先，判断对象的类型，如果是标注对象，那么就进行相关的操作，否则略过。这个事件其实是图形数据库变更的触发事件，因而对象的类型就比较多，比如在VBA中平常所没有的块表对象、层表对象、块表记录对象等，如果熟悉ARX的话，理解它的原因就比较简单。

lhx2000

'将像素转换成ACAD的当前图形单位。
Function PixelsToAcadUnit(ByVal Pixels As Integer) As Double
    Dim ViewSize As Double
    ViewSize = acadDoc.GetVariable("VIEWSIZE")
    Dim ScreenSize As Variant
    ScreenSize = acadDoc.GetVariable("SCREENSIZE")
    PixelsToAcadUnit = Pixels * ViewSize / ScreenSize(1)
End Function
哪位能给解释以下 SCREENSIZE  和 VIEWSIZE的意思和关系
想解决一个问题：目前的视口大小表示多少实际尺寸