[转帖]获取Dimension的defpoint
本帖最后由 作者 于 2008-6-26 8:51:28 编辑来自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.
对于尺寸线类型要从捕捉隐藏的尺寸线定义块入手，其策略是正在使用的尺寸块的句柄。
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 ProgrameSub 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
本帖最后由 作者 于 2008-4-10 11:55:15 编辑
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
页:
[1]