[原创]AcadDimension
本帖最后由 作者 于 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
读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
页:
[1]