[原创]AcadDimension

兰州人 · 发表于 2008-4-6 11:13:00

本帖最后由作者于 2008-9-17 10:55:34 编辑

  Sub lll()
''
  Dim dd As AcadDimension
  Dim r1 As AcadDim3PointAngular, r2 As AcadDimAligned, r3 As AcadDimAngular
  Dim r4 As AcadDimDiametric, r5 As AcadDimOrdinate, r6 As AcadDimRadial
  Dim r7 As AcadDimRotated
  Dim r8 As AcadDimStyle, r9 As AcadDimStyles
''
Dim ii As Integer
ii = 1
  Dim Ent As AcadEntity
  For Each Ent In ThisDrawing.ModelSpace
'Debug.Print Ent.ObjectName

Select Case Ent.ObjectName
   Case "AcDbdimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbAlignedDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDb2LineAngularDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbDiametricDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbLeader"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbOrdinateDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbRadialDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbRotatedDimension"
   Debug.Print ii, Ent.ObjectName, TypeOf Ent Is AcadDimension
   Case "AcDbStyle"
   Debug.Print Ent.ObjectName
   Case "AcDbStyles"
   Debug.Print Ent.ObjectName
End Select

  ii = ii + 1
  Next
End Sub
Debug.Print
1          AcDbRadialDimension          True
2          AcDbRotatedDimension       True
3          AcDbDiametricDimension    True
4          AcDbAlignedDimension       True
5          AcDbLeader                         False
6          AcDbOrdinateDimension    True
结论：
AcDbdimension---包含
1          AcDbRadialDimension          True
2          AcDbRotatedDimension       True
3          AcDbDiametricDimension    True
4          AcDbAlignedDimension       True
6          AcDbOrdinateDimension    True
AcDbdimension--不包含
5          AcDbLeader                         False

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=15468&replyID=73915&skin=1
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=18920&replyID=&skin=1
   gpcode(0) = 0
      datavalue(0) = "DimRadial"
      groupcode = gpcode: datacode = datavalue
      Set myss = ThisDrawing.SelectionSets.Add("ms1")
      Call myss.Select(acSelectionSetAll, , , groupcode, datacode)
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=18920

70



标注类型：
值 0-6 是整数值，表示标注类型。值 32、64 和 128 是添加到整数值的位值（在 R13 及以后的版本中始终设置为 32）
0 = 旋转、水平或垂直；1 = 对齐
2 = 角度；3 = 直径；4 = 半径
5 = 三点角度；6 = 坐标
32 = 表示块参照（组码 2）仅由该标注参照。
64 = 坐标类型。这是一个位值（位 7），仅与整数值 6 一起使用。如果设置该值，则坐标为 X 类型；如果不设置，则坐标为 Y 类型。
128 = 这是一个添加到其他组 70 值的位值（位 8）（如果标注文字已放置到用户定义的位置，而不是放置到默认位置）

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=51052&replyID=16447&skin=1

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
Dim sSet As AcadSelectionSet
'ThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: "
Set sSet = ReadTable
For Each objDim0 In sSet
On Error Resume Next
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
Debug.Print "Start Point = " & varDimLdrSPt(0) & "," & varDimLdrSPt(1) & vbCrLf & _
"End Point = " & varDimLdrEpt(0) & "," & varDimLdrEpt(1)
End If
Next objDim0
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
Function CreatSelectionSet(InputEntityObjectName As Variant) As AcadSelectionSet
On Error Resume Next
Dim ii
'Dim SSet As AcadSelectionSet
Dim Pt1, Pt2
If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then
Set CreatSelectionSet = ThisDrawing.SelectionSets.Item("SelectEntity")
CreatSelectionSet.Delete
End If
Set CreatSelectionSet = ThisDrawing.SelectionSets.Add("SelectEntity")
'Pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")
'Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "Input First Point")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
For ii = 0 To UBound(InputEntityObjectName)
dataValue(ii) = InputEntityObjectName(ii)
Next ii
CreatSelectionSet.Select acSelectionSetAll, , , gpCode, dataValue
End Function
Function ReadTable() As AcadSelectionSet
Dim sSet As AcadSelectionSet
Dim InputEntityObjectName As Variant
InputEntityObjectName = Array("Dimension")
Set sSet = CreatSelectionSet(InputEntityObjectName)
Dim Ent As AcadEntity
Set ReadTable = sSet
End Function
Sub llss()
Dim sSet As AcadSelectionSet
Dim objDim As AcadDimension, objDimCopy As AcadDimension
Set sSet = ReadTable
For Each objDim In sSet
Set objDimCopy = objDim.Copy()
'Debug.Print objDimCopy.Handle, objDim.Handle
objDimCopy.color = 1
objDim.Delete
Next objDim
End Sub

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
  Dim sSet As AcadSelectionSet
  'ThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: "
  Set sSet = ReadTable
For Each objDim0 In sSet
 On Error Resume Next
  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
    Debug.Print "Start Point = " & varDimLdrSPt(0) & "," & varDimLdrSPt(1) & vbCrLf & _
    "End Point = " & varDimLdrEpt(0) & "," & varDimLdrEpt(1)
  End If
Next objDim0
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
Function CreatSelectionSet(InputEntityObjectName As Variant) As AcadSelectionSet
   On Error Resume Next
   Dim ii
   'Dim SSet As AcadSelectionSet
   Dim Pt1, Pt2
   If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then
     Set CreatSelectionSet = ThisDrawing.SelectionSets.Item("SelectEntity")
     CreatSelectionSet.Delete
   End If
   Set CreatSelectionSet = ThisDrawing.SelectionSets.Add("SelectEntity")
   'Pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")
   'Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "Input First Point")
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   gpCode(0) = 0
   For ii = 0 To UBound(InputEntityObjectName)
     dataValue(ii) = InputEntityObjectName(ii)
   Next ii
   CreatSelectionSet.Select acSelectionSetAll, , , gpCode, dataValue
End Function
Function ReadTable() As AcadSelectionSet
   Dim sSet As AcadSelectionSet
   Dim InputEntityObjectName As Variant
   InputEntityObjectName = Array("Dimension")
   Set sSet = CreatSelectionSet(InputEntityObjectName)
   Dim Ent As AcadEntity
   Set ReadTable = sSet
End Function

Sub llss()
  Dim sSet As AcadSelectionSet
  Dim objDim As AcadDimension, objDimCopy As AcadDimension
  Set sSet = ReadTable
  
  For Each objDim In sSet
    Set objDimCopy = objDim.Copy()
    'Debug.Print objDimCopy.Handle, objDim.Handle
    
    objDimCopy.color = 1
    objDim.Delete
  Next objDim
End Sub

读Dimension数据

Dim ReturnXls As New ObjectXlsMdbTxtData
Sub ReadTextFromDwg()
Dim xls As Worksheet
Set xls = ReturnXls.ReturnxlSheet("Sheet1")
Dim ee As AcadEntity, gg As AcadBlock
Dim objMtext As AcadMText
With ThisDrawing.Utility
For jj = 1 To 1
tt = xls.Cells(2, jj)
.GetEntity ee, pp, tt
Select Case InStr(ee.ObjectName, "Dimension")
Case Is > 0
Set gg = GetDefinition(ee.Handle)
For kk = 0 To gg.Count - 1
Select Case gg.Item(kk).ObjectName
Case "AcDbMText"
Set objMtext = gg.Item(kk)
Debug.Print objMtext.TextString
End Select
Next kk
End Select
Next jj
End With
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

Dim ReturnXls As New ObjectXlsMdbTxtData
Sub ReadTextFromDwg()
  Dim xls As Worksheet
  Set xls = ReturnXls.ReturnxlSheet("Sheet1")
  Dim ee As AcadEntity, gg As AcadBlock
  Dim objMtext As AcadMText
  With ThisDrawing.Utility
    For jj = 1 To 1
        tt = xls.Cells(2, jj)
        .GetEntity ee, pp, tt
        Select Case InStr(ee.ObjectName, "Dimension")
          Case Is > 0
            Set gg = GetDefinition(ee.Handle)
            For kk = 0 To gg.Count - 1
              
              Select Case gg.Item(kk).ObjectName
                Case "AcDbMText"
                  Set objMtext = gg.Item(kk)
                  Debug.Print objMtext.TextString
              End Select
            Next kk
        End Select
        
        
    Next jj
  End With
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

账号		自动登录	找回密码
密码			注册