[转帖]获取Dimension的defpoint

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

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

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