Code:
Public Sub Flach()
Call Parameter
Call Flach_1
Call Comments
End SubPublic Sub Parameter()
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument
Dim oParams As Inventor.Parameters
Set oParams = oDoc.ComponentDefinition.Parameters
Dim oparam As Parameter
For Each oparam In oParams.ModelParameters
oparam.ExposedAsProperty = False
Next
End Sub
Public Sub Flach_1()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim oDoc As PartDocument
Set oDoc = oApp.ActiveDocument
Dim oPane As BrowserPane
Set oPane = oDoc.BrowserPanes("Modell")
Call oPane.TopNode.DoSelect
Dim oBrowserNode As BrowserNode
For Each oBrowserNode In ThisApplication.ActiveDocument.BrowserPanes.Item("Modell").TopNode.BrowserNodes
If Right(oBrowserNode.FullPath, 10) = "Abwicklung" Then
oBrowserNode.DoSelect
End If
Next
Dim oCompDef As ComponentDefinition
Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition
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 sLänge As String
'Dim sBreite As String
'Dim sStärke As String
Dim rLänge As String
Dim rBreite As String
Dim rStärke As String
'festlegen, dass Länge immer Lännge, Breite immer Breite und Stärke immer Stärke ist
If (MaxPoint(2) - MinPoint(2)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(2) - MinPoint(2)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(1) - MinPoint(1) > (MaxPoint(3) - MinPoint(3))) Then
rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
rStärke = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
ElseIf (MaxPoint(3) - MinPoint(3)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(3) - MinPoint(3)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(1) - MinPoint(1) > (MaxPoint(2) - MinPoint(2))) Then
rLänge = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
ElseIf (MaxPoint(1) - MinPoint(1)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(1) - MinPoint(1)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(3) - MinPoint(3) > (MaxPoint(2) - MinPoint(2))) Then
rLänge = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
rBreite = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
ElseIf (MaxPoint(2) - MinPoint(2)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(2) - MinPoint(2)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(3) - MinPoint(3) > (MaxPoint(1) - MinPoint(1))) Then
rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
rBreite = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
rStärke = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
ElseIf (MaxPoint(3) - MinPoint(3)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(3) - MinPoint(3)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(2) - MinPoint(2) > (MaxPoint(1) - MinPoint(1))) Then
rLänge = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
rBreite = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
rStärke = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
Else
rLänge = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
rBreite = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
rStärke = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
End If
MsgBox "Länge: " & rLänge & sLengthUnit & Chr(13) & Chr(10) & "Breite: " & rBreite & sLengthUnit & Chr(13) & Chr(10) & "Stärke: " & rStärke & sLengthUnit
Dim bLängeDa As Boolean
Dim oProper As Property
bLängeDa = False
For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProper.Name = "Länge" Then
bLängeDa = True
Exit For
End If
Next
'Länge eintragen oder ändern
If bLängeDa Then
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Länge").Value = rLänge
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rLänge, "Länge"
End If
'Breite vorhanden?
Dim bBreiteDa As Boolean
bBreiteDa = False
For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProper.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 = rBreite
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rBreite, "Breite"
End If
'Stärke vorhanden?
Dim bStärkeDa As Boolean
bStärkeDa = False
For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
If oProper.Name = "Stärke" Then
bStärkeDa = True
Exit For
End If
Next
'Höhe eintragen oder ändern
If bStärkeDa Then
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Stärke").Value = rStärke
Else
oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rStärke, "Stärke"
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
Public Sub Comments()
Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
Dim oPropSet As PropertySet
For Each oPropSet In oPropSets
For i = 1 To oPropSet.Count
If oPropSet(i).Name = "Comments" Then
On Error Resume Next
Debug.Print oPropSet(i).Name & " " & oPropSet(i).Value
oPropSet(i).Value = "=<Stärke>x<Breite>x<Länge>"
End If
If oPropSet(i).Name = "Creation Time" Then
On Error Resume Next
Debug.Print oPropSet(i).Name & " " & oPropSet(i).Value
oPropSet(i).Value = Now
End If
Next i
Next oPropSet
End Sub