Code:
Public Sub DrawRangeBox()
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
' Set a reference to component definition of the active document.
' This assumes that a part or assembly document is active.
Dim oCompDef As ComponentDefinition
Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition
' Make sure something is selected.
If oDoc.SelectSet.Count = 0 Then
MsgBox "Bitte vorher Baugruppe auswählen."
' Delete any graphics, if they exist.
On Error Resume Next
Dim oExistingGraphicsData As GraphicsDataSets
Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
If Err.Number = 0 Then
On Error GoTo 0
Dim oExistingGraphics As ClientGraphics
Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
oExistingGraphics.Delete
oExistingGraphicsData.Delete
ThisApplication.ActiveView.Update
End If
Exit Sub
End If
ReDim aoRanges(1 To oDoc.SelectSet.Count) As Box
Dim iRangeCount As Long
Dim i As Long
On Error Resume Next
For i = 1 To oDoc.SelectSet.Count
Dim oBox As Box
Set oBox = oDoc.SelectSet.Item(i).RangeBox
If Err Then
Err.Clear
' Special case for B-Rep entities.
If oDoc.SelectSet.Item(i).Type = kFaceObject Or _
oDoc.SelectSet.Item(i).Type = kFaceProxyObject Or _
oDoc.SelectSet.Item(i).Type = kEdgeObject Or _
oDoc.SelectSet.Item(i).Type = kEdgeProxyObject Then
' Get the range from evaluator of the BRep object.
Set oBox = oDoc.SelectSet.Item(i).Evaluator.RangeBox
iRangeCount = iRangeCount + 1
Set aoRanges(iRangeCount) = oBox
End If
Else
iRangeCount = iRangeCount + 1
Set aoRanges(iRangeCount) = oBox
End If
Next
On Error GoTo 0
If iRangeCount = 0 Then
MsgBox "You must pick object(s) that support a 3D RangeBox property."
Exit Sub
End If
' Check to see if range box graphics information already exists.
On Error Resume Next
Dim oClientGraphics As ClientGraphics
Dim oLineGraphics As LineGraphics
Dim oBoxNode As GraphicsNode
Dim oGraphicsData As GraphicsDataSets
Set oGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
If Err Then
Err.Clear
On Error GoTo 0
' Set a reference to the transient geometry object for user later.
Dim oTransGeom As TransientGeometry
Set oTransGeom = ThisApplication.TransientGeometry
' Create a graphics data set object. This object contains all of the
' information used to define the graphics.
Dim oDataSets As GraphicsDataSets
Set oDataSets = oDoc.GraphicsDataSetsCollection.Add("RangeBoxGraphics")
' Create a coordinate set.
Dim oCoordSet As GraphicsCoordinateSet
Set oCoordSet = oDataSets.CreateCoordinateSet(1)
' Create the client graphics for this compdef.
Set oClientGraphics = oCompDef.ClientGraphicsCollection.Add("RangeBoxGraphics")
' Create a graphics node.
Set oBoxNode = oClientGraphics.AddNode(1)
oBoxNode.Selectable = False
' Create line graphics.
Set oLineGraphics = oBoxNode.AddLineGraphics
oLineGraphics.CoordinateSet = oCoordSet
Else
Set oCoordSet = oGraphicsData.ItemById(1)
Set oBoxNode = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics").ItemById(1)
End If
Dim dBoxLines() As Double
ReDim dBoxLines(1 To 12 * 6 * iRangeCount) As Double
For i = 0 To iRangeCount - 1
Dim MinPoint(1 To 3) As Double
Dim MaxPoint(1 To 3) As Double
Call aoRanges(i + 1).GetBoxData(MinPoint, MaxPoint)
' Line 1
dBoxLines(i * 72 + 1) = MinPoint(1)
dBoxLines(i * 72 + 2) = MinPoint(2)
dBoxLines(i * 72 + 3) = MinPoint(3)
dBoxLines(i * 72 + 4) = MaxPoint(1)
dBoxLines(i * 72 + 5) = MinPoint(2)
dBoxLines(i * 72 + 6) = MinPoint(3)
' Line 2
dBoxLines(i * 72 + 7) = MinPoint(1)
dBoxLines(i * 72 + 8) = MinPoint(2)
dBoxLines(i * 72 + 9) = MinPoint(3)
dBoxLines(i * 72 + 10) = MinPoint(1)
dBoxLines(i * 72 + 11) = MaxPoint(2)
dBoxLines(i * 72 + 12) = MinPoint(3)
' Line 3
dBoxLines(i * 72 + 13) = MinPoint(1)
dBoxLines(i * 72 + 14) = MinPoint(2)
dBoxLines(i * 72 + 15) = MinPoint(3)
dBoxLines(i * 72 + 16) = MinPoint(1)
dBoxLines(i * 72 + 17) = MinPoint(2)
dBoxLines(i * 72 + 18) = MaxPoint(3)
' Line 4
dBoxLines(i * 72 + 19) = MaxPoint(1)
dBoxLines(i * 72 + 20) = MaxPoint(2)
dBoxLines(i * 72 + 21) = MaxPoint(3)
dBoxLines(i * 72 + 22) = MinPoint(1)
dBoxLines(i * 72 + 23) = MaxPoint(2)
dBoxLines(i * 72 + 24) = MaxPoint(3)
' Line 5
dBoxLines(i * 72 + 25) = MaxPoint(1)
dBoxLines(i * 72 + 26) = MaxPoint(2)
dBoxLines(i * 72 + 27) = MaxPoint(3)
dBoxLines(i * 72 + 28) = MaxPoint(1)
dBoxLines(i * 72 + 29) = MinPoint(2)
dBoxLines(i * 72 + 30) = MaxPoint(3)
' Line 6
dBoxLines(i * 72 + 31) = MaxPoint(1)
dBoxLines(i * 72 + 32) = MaxPoint(2)
dBoxLines(i * 72 + 33) = MaxPoint(3)
dBoxLines(i * 72 + 34) = MaxPoint(1)
dBoxLines(i * 72 + 35) = MaxPoint(2)
dBoxLines(i * 72 + 36) = MinPoint(3)
' Line 7
dBoxLines(i * 72 + 37) = MinPoint(1)
dBoxLines(i * 72 + 38) = MaxPoint(2)
dBoxLines(i * 72 + 39) = MinPoint(3)
dBoxLines(i * 72 + 40) = MaxPoint(1)
dBoxLines(i * 72 + 41) = MaxPoint(2)
dBoxLines(i * 72 + 42) = MinPoint(3)
' Line 8
dBoxLines(i * 72 + 43) = MinPoint(1)
dBoxLines(i * 72 + 44) = MaxPoint(2)
dBoxLines(i * 72 + 45) = MinPoint(3)
dBoxLines(i * 72 + 46) = MinPoint(1)
dBoxLines(i * 72 + 47) = MaxPoint(2)
dBoxLines(i * 72 + 48) = MaxPoint(3)
' Line 9
dBoxLines(i * 72 + 49) = MaxPoint(1)
dBoxLines(i * 72 + 50) = MinPoint(2)
dBoxLines(i * 72 + 51) = MaxPoint(3)
dBoxLines(i * 72 + 52) = MaxPoint(1)
dBoxLines(i * 72 + 53) = MinPoint(2)
dBoxLines(i * 72 + 54) = MinPoint(3)
' Line 10
dBoxLines(i * 72 + 55) = MaxPoint(1)
dBoxLines(i * 72 + 56) = MinPoint(2)
dBoxLines(i * 72 + 57) = MaxPoint(3)
dBoxLines(i * 72 + 58) = MinPoint(1)
dBoxLines(i * 72 + 59) = MinPoint(2)
dBoxLines(i * 72 + 60) = MaxPoint(3)
' Line 11
dBoxLines(i * 72 + 61) = MinPoint(1)
dBoxLines(i * 72 + 62) = MinPoint(2)
dBoxLines(i * 72 + 63) = MaxPoint(3)
dBoxLines(i * 72 + 64) = MinPoint(1)
dBoxLines(i * 72 + 65) = MaxPoint(2)
dBoxLines(i * 72 + 66) = MaxPoint(3)
' Line 12
dBoxLines(i * 72 + 67) = MaxPoint(1)
dBoxLines(i * 72 + 68) = MinPoint(2)
dBoxLines(i * 72 + 69) = MinPoint(3)
dBoxLines(i * 72 + 70) = MaxPoint(1)
dBoxLines(i * 72 + 71) = MaxPoint(2)
dBoxLines(i * 72 + 72) = MinPoint(3)
Next
' Assign the points into the coordinate set.
Call oCoordSet.PutCoordinates(dBoxLines)
' Update the display.
ThisApplication.ActiveView.Update
' Create a string that defines an area using the current length unit.
Dim oUOM As UnitsOfMeasure
Set oUOM = ThisApplication.ActiveDocument.UnitsOfMeasure
' Get the enum value that defines the current default length units.
Dim eLengthUnit As UnitsTypeEnum
eLengthUnit = oUOM.LengthUnits
' Get the equivalent string of the enum value.
Dim sLengthUnit As String
sLengthUnit = " " & oUOM.GetStringFromType(eLengthUnit)
Dim sLaenge As String
Dim sBreite As String
Dim sHoehe As String
Dim rLaenge As Double
rLaenge = (MaxPoint(1) - MinPoint(1)) * 10
sLaenge = Format$(rLaenge, "##0")
Dim rBreite As Double
rBreite = (MaxPoint(2) - MinPoint(2)) * 10
sBreite = Format$(rBreite, "##0")
Dim rHoehe As Double
rHoehe = (MaxPoint(3) - MinPoint(3)) * 10
sHoehe = Format$(rHoehe, "##0")
MsgBox "Länge: " & sLaenge & sLengthUnit & Chr(13) & Chr(10) & "Breite: " & sBreite & sLengthUnit & Chr(13) & Chr(10) & "Höhe: " & sHoehe & sLengthUnit
sLaenge = Replace(sLaenge, ",", ".", vbTextCompare)
sBreite = Replace(sBreite, ",", ".", vbTextCompare)
sHoehe = Replace(sHoehe, ",", ".", vbTextCompare)
'Benutzerdefinierten Eintrag erzeugen
'Länge vorhanden?
Dim bLaengeDa As Boolean
Dim oProp As Property
bLaengeDa = False
For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProp.Name = "Laenge" Then
bLaengeDa = True
Exit For
End If
Next
'Länge eintragen oder ändern
If bLaengeDa Then
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Laenge").Value = sLaenge
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sLaenge, "Laenge"
End If
'Breite vorhanden?
Dim bBreiteDa As Boolean
bBreiteDa = False
For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProp.Name = "Breite" Then
bBreiteDa = True
Exit For
End If
Next
'Breite eintragen oder ändern
If bBreiteDa Then
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Breite").Value = sBreite
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sBreite, "Breite"
End If
'Höhe vorhanden?
Dim bHoeheDa As Boolean
bHoeheDa = False
For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProp.Name = "Hoehe" Then
bHoeheDa = True
Exit For
End If
Next
'Höhe eintragen oder ändern
If bHoeheDa Then
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Hoehe").Value = sHoehe
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sHoehe, "Hoehe"
End If
'Da die ClientGraphic nur temporär sein soll, wird sie nach Bestätigen
'der Meldung wieder gelöscht.
If oDoc.SelectSet.Count = 0 Then
' Delete any graphics, if they exist.
On Error Resume Next
Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
If Err.Number = 0 Then
On Error GoTo 0
Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
oExistingGraphics.Delete
oExistingGraphicsData.Delete
ThisApplication.ActiveView.Update
End If
Exit Sub
End If
End Sub