[转帖]获取Dimension的defpoint

兰州人

来自http://discussion.autodesk.com/thread.jspa?messageID=430762
About the type of dimension, just that it IS a dimension. From there, you grab the
hidden block for the dimension. The trick is to grab the
dimension's block using the handle of the dimension. Check out his website
http://www.vbdesign.net/ for more info on obtaining the dimension's block.
对于尺寸线类型要从捕捉隐藏的尺寸线定义块入手，其策略是正在使用的尺寸块的句柄。

2. Option Explicit
3. Sub DimPts()
4. Dim objDim0 As AcadDimension
5. Dim objDimDefBlk As AcadBlock
6. Dim varPickPt As Variant
7. Dim varDimLdrSPt As Variant
8. Dim varDimLdrEpt As Variant
9. Dim varDimTxtPt As Variant
10. Dim intCntr As Integer
11. intCntr = 0
12. Dim intCntr2 As Integer
13. intCntr2 = 0
14. Dim objTestEntity As AcadEntity
15. Dim objTestPt As AcadPoint
16. Dim strMessage As String
17. ThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: "
18. If objDim0 Is Nothing Then
19. MsgBox "You failed to pick a dimension object", vbCritical
20. Exit Sub
21. ElseIf TypeOf objDim0 Is AcadDimension Then
22. Set objDimDefBlk = GetDefinition(objDim0.Handle)
23. For intCntr = 0 To objDimDefBlk.Count - 1
24. Set objTestEntity = objDimDefBlk(intCntr)
25. If TypeOf objTestEntity Is AcadPoint Then
26. Set objTestPt = objTestEntity
27. Select Case intCntr2
28. Case 0
29. varDimLdrSPt = objTestPt.Coordinates
30. intCntr2 = intCntr2 + 1
31. Case 1
32. varDimLdrEpt = objTestPt.Coordinates
33. intCntr2 = intCntr2 + 1
34. Case 2
35. varDimTxtPt = objTestPt.Coordinates
36. intCntr2 = intCntr2 + 1
37. End Select
38. End If
39. Next
40. MsgBox "Start Point = " & varDimLdrSPt(0) & "," & varDimLdrSPt(1) & vbCrLf & _
41. "End Point = " & varDimLdrEpt(0) & "," & varDimLdrEpt(1)
42. End If
43. End Sub
44. Function GetDefinition(strHandle As String) As AcadBlock
45. ' Returns a dimension's controlling block
46. Dim objBlk As AcadBlock
47. Dim strLeft As String
48. Dim strRight As String
49. Dim blnTest As Boolean
50. On Error GoTo Err_Control
51. strLeft = Left(strHandle, Len(strHandle) - 2)
52. strRight = "&H" & Right(strHandle, 2)
53. strRight = strRight + 1
54. strHandle = strLeft & Hex(strRight)
55. blnTest = True
56. Set objBlk = ThisDrawing.HandleToObject(strHandle)
57. Set GetDefinition = objBlk
58. Exit_Here:
59. Exit Function
60. Err_Control:
61. Select Case Err.Number
62. Case 13 'Type Mismatch
63. If blnTest Then
64. strRight = strRight + 1
65. strHandle = strLeft & Hex(strRight)
66. Err.Clear
67. 'single increment only! Reset test
68. blnTest = Not blnTest
69. Resume
70. Else
71. 'second time in or other mismatch
72. Err.Raise Err.Number, Err.Source, Err.Description, _
73. Err.HelpFile, Err.HelpContext
74. End If
75. Case -2147467259
76. Err.Clear
77. MsgBox "Invalid dimension entity...", vbCritical
78. End
79. Case Else
80. Err.Raise Err.Number, Err.Source, Err.Description, _
81. Err.HelpFile, Err.HelpContext
82. End Select
83. End Function

Option Explicit Sub DimPts() Dim objDim0 As AcadDimension Dim objDimDefBlk As AcadBlock Dim varPickPt As Variant Dim varDimLdrSPt As Variant Dim varDimLdrEpt As Variant Dim varDimTxtPt As Variant Dim intCntr As Integer intCntr = 0 Dim intCntr2 As Integer intCntr2 = 0 Dim objTestEntity As AcadEntity Dim objTestPt As AcadPoint Dim strMessage As String ThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: " If objDim0 Is Nothing Then MsgBox "You failed to pick a dimension object", vbCritical Exit Sub ElseIf TypeOf objDim0 Is AcadDimension Then Set objDimDefBlk = GetDefinition(objDim0.Handle) For intCntr = 0 To objDimDefBlk.Count - 1 Set objTestEntity = objDimDefBlk(intCntr) If TypeOf objTestEntity Is AcadPoint Then Set objTestPt = objTestEntity Select Case intCntr2 Case 0 varDimLdrSPt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 Case 1 varDimLdrEpt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 Case 2 varDimTxtPt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 End Select End If Next MsgBox "Start Point = " & varDimLdrSPt(0) & "," & varDimLdrSPt(1) & vbCrLf & _ "End Point = " & varDimLdrEpt(0) & "," & varDimLdrEpt(1) End If End Sub Function GetDefinition(strHandle As String) As AcadBlock ' Returns a dimension's controlling block Dim objBlk As AcadBlock Dim strLeft As String Dim strRight As String Dim blnTest As Boolean On Error GoTo Err_Control strLeft = Left(strHandle, Len(strHandle) - 2) strRight = "&H" & Right(strHandle, 2) strRight = strRight + 1 strHandle = strLeft & Hex(strRight) blnTest = True Set objBlk = ThisDrawing.HandleToObject(strHandle) Set GetDefinition = objBlk Exit_Here: Exit Function Err_Control: Select Case Err.Number Case 13 'Type Mismatch If blnTest Then strRight = strRight + 1 strHandle = strLeft & Hex(strRight) Err.Clear 'single increment only! Reset test blnTest = Not blnTest Resume Else 'second time in or other mismatch Err.Raise Err.Number, Err.Source, Err.Description, _ Err.HelpFile, Err.HelpContext End If Case -2147467259 Err.Clear MsgBox "Invalid dimension entity...", vbCritical End Case Else Err.Raise Err.Number, Err.Source, Err.Description, _ Err.HelpFile, Err.HelpContext End Select End Function

返回对齐标注或转角标注的标注点坐标
http://www.mjtd.com/e-zine/mezine0505.HTM#605
锁定dim标注数值VBA版(支持公差等格式)
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=27492&extra=&page=1
Change Programe

2. Sub ll()
3.   Dim varPickPt As Variant
4.   Dim ddd As AcadDimension, strHandle As String
5.   Dim strLeft As String, strRight As String
6.   Dim bb As AcadBlock
7.   'Set ddd = ThisDrawing.HandleToObject(ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1).Handle)
8.   ThisDrawing.Utility.GetEntity ddd, varPickPt, "Select Dimension"
9.   Debug.Print ddd.ObjectName, ddd.Handle
10. Dim ii As Integer, iii As Integer
11. For ii = 1 To 13
12.   'Debug.Print ddd.Handle
13.   strLeft = Left(ddd.Handle, Len(ddd.Handle) - 2)
14.   Debug.Print strLeft
15.   strRight = "&H" & Right(ddd.Handle, 2)
16.   Debug.Print strRight
17.   strRight = strRight + ii
18.   strHandle = strLeft & Hex(strRight)
19.   Debug.Print strHandle
20.   
21.   Debug.Print ii, TypeName(ThisDrawing.HandleToObject(strHandle))
22.   If TypeName(ThisDrawing.HandleToObject(strHandle)) = "IAcadBlock" Then
23.     Set bb = ThisDrawing.HandleToObject(strHandle)
24.     For iii = 0 To bb.Count - 1
25.       Debug.Print bb(iii).ObjectName
26.     Next
27.     Exit For
28.   End If
29. Next ii
30. Debug.Print "aaaaaaaa"
31. End Sub

Sub ll()   Dim varPickPt As Variant   Dim ddd As AcadDimension, strHandle As String   Dim strLeft As String, strRight As String   Dim bb As AcadBlock   'Set ddd = ThisDrawing.HandleToObject(ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1).Handle)   ThisDrawing.Utility.GetEntity ddd, varPickPt, "Select Dimension"   Debug.Print ddd.ObjectName, ddd.Handle Dim ii As Integer, iii As Integer For ii = 1 To 13   'Debug.Print ddd.Handle   strLeft = Left(ddd.Handle, Len(ddd.Handle) - 2)   Debug.Print strLeft   strRight = "&H" & Right(ddd.Handle, 2)   Debug.Print strRight   strRight = strRight + ii   strHandle = strLeft & Hex(strRight)   Debug.Print strHandle      Debug.Print ii, TypeName(ThisDrawing.HandleToObject(strHandle))   If TypeName(ThisDrawing.HandleToObject(strHandle)) = "IAcadBlock" Then     Set bb = ThisDrawing.HandleToObject(strHandle)     For iii = 0 To bb.Count - 1       Debug.Print bb(iii).ObjectName     Next     Exit For   End If Next ii Debug.Print "aaaaaaaa" End Sub

兰州人

2. Sub ls()
3. Dim ii As Integer
4. Dim strLeft As String, strRight As String
5. ii = 2
6. Dim xlSheet1 As Worksheet, xlSheet2 As Worksheet
7. Set xlSheet1 = xlApp.Sheets(1)
9. Dim Ent As AcadBlock, Ee As AcadEntity
10. Debug.Print "ModelSpace"
11.     Dim SSet As AcadSelectionSet
12.     On Error Resume Next
13.     '建立选择集
14.     ThisDrawing.SelectionSets("mccad").Delete
15.     Set SSet = ThisDrawing.SelectionSets.Add("mccad")
16.     '建立过滤器
17.     Dim fType(0) As Integer
18.     Dim fData(0) As Variant
19.     fType(0) = 0
20.     fData(0) = "DIMENSION"
21.     '选择过滤出图形中所有的标注对象
22.     SSet.Select acSelectionSetAll, , , fType, fData
23.     Dim i As Long
24.     For i = 0 To SSet.Count - 1
25.       xlSheet1.Cells(ii, 1).Value = SSet(i).ObjectName
26.       xlSheet1.Cells(ii, 2).Value = TypeName(SSet(i))
27.       xlSheet1.Cells(ii, 3).Value = "'" & SSet(i).Handle
28.       cc = SSet(i).Handle
29.       strLeft = Left(cc, Len(cc) - 2)
30.       strRight = "&H" & Right(cc, 2)
31.       xlSheet1.Cells(ii, 4).Value = strLeft + Hex(strRight + 1)
32.       
33.       ii = ii + 1
34.     Next
36. ' For Each Ee In ThisDrawing.ModelSpace
37. ' Next
38. Set xlSheet1 = Nothing
40. Set xlSheet2 = xlApp.Sheets(2)
41. Debug.Print
42. Debug.Print "Blocks"
43. ii = 2
44. For Each Ent In ThisDrawing.Blocks
45.    If TypeName(Ent) = "IAcadBlock" And Ent.Handle <> "55" Then
46.      xlSheet2.Cells(ii, 1).Value = Ent.ObjectName
47.      xlSheet2.Cells(ii, 2).Value = TypeName(Ent)
48.      xlSheet2.Cells(ii, 3).Value = "'" & Ent.Handle
49.      xlSheet2.Cells(ii, 4).Value = Ent.Count
50.      ii = ii + 1
51.    End If
52. Next
53. Set xlSheet2 = Nothing
55. End Sub
56. Function xlApp() As Object
57. '  Dim xlApp As Object    ' This Line ,Not set Excel , run Excel
58.       'Dim xlsheet As Object
59.       
60.       ' 发生错误时跳到下一个语句继续执行
61.       On Error Resume Next
62.       ' 连接Excel应用程序
63.       Set xlApp = GetObject(, "Excel.Application")
64.       
65.       If Err.Number <> 0 Then
66.           Set xlApp = CreateObject("Excel.Application")
67.           xlApp.Visible = True
68.           xlApp.Workbooks.Add
69.       End If
70.       ' 返回当前活动的工作表
71. End Function

Sub ls() Dim ii As Integer Dim strLeft As String, strRight As String ii = 2 Dim xlSheet1 As Worksheet, xlSheet2 As Worksheet Set xlSheet1 = xlApp.Sheets(1) Dim Ent As AcadBlock, Ee As AcadEntity Debug.Print "ModelSpace"     Dim SSet As AcadSelectionSet     On Error Resume Next     '建立选择集     ThisDrawing.SelectionSets("mccad").Delete     Set SSet = ThisDrawing.SelectionSets.Add("mccad")     '建立过滤器     Dim fType(0) As Integer     Dim fData(0) As Variant     fType(0) = 0     fData(0) = "DIMENSION"     '选择过滤出图形中所有的标注对象     SSet.Select acSelectionSetAll, , , fType, fData     Dim i As Long     For i = 0 To SSet.Count - 1       xlSheet1.Cells(ii, 1).Value = SSet(i).ObjectName       xlSheet1.Cells(ii, 2).Value = TypeName(SSet(i))       xlSheet1.Cells(ii, 3).Value = "'" & SSet(i).Handle       cc = SSet(i).Handle       strLeft = Left(cc, Len(cc) - 2)       strRight = "&H" & Right(cc, 2)       xlSheet1.Cells(ii, 4).Value = strLeft + Hex(strRight + 1)              ii = ii + 1     Next ' For Each Ee In ThisDrawing.ModelSpace ' Next Set xlSheet1 = Nothing Set xlSheet2 = xlApp.Sheets(2) Debug.Print Debug.Print "Blocks" ii = 2 For Each Ent In ThisDrawing.Blocks    If TypeName(Ent) = "IAcadBlock" And Ent.Handle <> "55" Then      xlSheet2.Cells(ii, 1).Value = Ent.ObjectName      xlSheet2.Cells(ii, 2).Value = TypeName(Ent)      xlSheet2.Cells(ii, 3).Value = "'" & Ent.Handle      xlSheet2.Cells(ii, 4).Value = Ent.Count      ii = ii + 1    End If Next Set xlSheet2 = Nothing End Sub Function xlApp() As Object '  Dim xlApp As Object    ' This Line ,Not set Excel , run Excel       'Dim xlsheet As Object              ' 发生错误时跳到下一个语句继续执行       On Error Resume Next       ' 连接Excel应用程序       Set xlApp = GetObject(, "Excel.Application")              If Err.Number <> 0 Then           Set xlApp = CreateObject("Excel.Application")           xlApp.Visible = True           xlApp.Workbooks.Add       End If       ' 返回当前活动的工作表 End Function