Code:
Private Sub AddLinearModelDims()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim oDoc As PartDocument
Set oDoc = oApp.ActiveDocument
Dim oCompDef As SheetMetalComponentDefinition
Set oCompDef = oDoc.ComponentDefinition
If oCompDef.Features.iFeatures.Count = 0 Then
Call MsgBox("No iFeatures.", vbInformation)
Exit Sub
End If
' Create 3 AnnotationPlaneDef
' Definition is reused by copying for each annotation
Dim oAnnoPlaneDef As AnnotationPlaneDefinition
Dim oAnnoPlaneDef_hoehe1 As AnnotationPlaneDefinition
Set oAnnoPlaneDef_hoehe1 = oCompDef.ModelAnnotations.CreateAnnotationPlaneDefinitionUsingPlane(oCompDef.WorkPlanes.Item("hoehe_1"), oCompDef.WorkAxes.Item(1)) 'Arbeitsebene "hoehe_1", X-Achse
Dim oAnnoPlaneDef_hoehe2 As AnnotationPlaneDefinition
Set oAnnoPlaneDef_hoehe2 = oCompDef.ModelAnnotations.CreateAnnotationPlaneDefinitionUsingPlane(oCompDef.WorkPlanes.Item("hoehe_2"), oCompDef.WorkAxes.Item(1)) 'Arbeitsebene "hoehe_2", X-Achse
Dim oAnnoPlaneDef_tiefe As AnnotationPlaneDefinition
Set oAnnoPlaneDef_tiefe = oCompDef.ModelAnnotations.CreateAnnotationPlaneDefinitionUsingPlane(oCompDef.WorkPlanes.Item("tiefe"), oCompDef.WorkAxes.Item(2)) 'Arbeitsebene "tiefe", Y-Achse
' Get the Origin
Dim oOrigin As WorkPoint
Set oOrigin = oCompDef.WorkPoints.Item(1)
' Create a GeometryIntent of the origin
Dim oIntent1 As GeometryIntent
Set oIntent1 = oCompDef.CreateGeometryIntent(oOrigin)
Dim oLinModelDims As LinearModelDimensions
Set oLinModelDims = oCompDef.ModelAnnotations.ModelDimensions.LinearModelDimensions
Dim dTextOffset As Double
dTextOffset = 10
' create an array of ifeatures with unique coordinates
Dim H1_x() As Variant
Dim H1_z() As Variant
Dim H2_x() As Variant
Dim H2_z() As Variant
Dim T_x() As Variant
Dim T_y() As Variant
Dim oiFeat As iFeature
For Each oiFeat In oCompDef.Features.iFeatures
Dim sNameParts() As String
sNameParts = Split(oiFeat.Name, "_")
Dim sName As String
sName = UCase(Left(sNameParts(UBound(sNameParts)), InStr(sNameParts(UBound(sNameParts)), ":") - 1))
Select Case sName
Case "H1":
Call AddToArray(oiFeat, oCompDef, "X", H1_x)
Call AddToArray(oiFeat, oCompDef, "Z", H1_z)
Case "H2":
Call AddToArray(oiFeat, oCompDef, "X", H2_x)
Call AddToArray(oiFeat, oCompDef, "Z", H2_z)
Case "T":
Call AddToArray(oiFeat, oCompDef, "X", T_x)
Call AddToArray(oiFeat, oCompDef, "Y", T_y)
End Select
Next
' sort all arrays in ascending order
Call BubbleSort(H1_x, "X")
Call BubbleSort(H1_z, "Z")
Call BubbleSort(H2_x, "X")
Call BubbleSort(H2_z, "Z")
Call BubbleSort(T_x, "X")
Call BubbleSort(T_y, "Y")
Dim aFeatArrs(0 To 5, 1) As Variant
aFeatArrs(0, 0) = H1_x
aFeatArrs(0, 1) = "X"
aFeatArrs(1, 0) = H1_z
aFeatArrs(1, 1) = "Z"
aFeatArrs(2, 0) = H2_x
aFeatArrs(2, 1) = "X"
aFeatArrs(3, 0) = H2_z
aFeatArrs(3, 1) = "Z"
aFeatArrs(4, 0) = T_x
aFeatArrs(4, 1) = "X"
aFeatArrs(5, 0) = T_y
aFeatArrs(5, 1) = "Y"
Dim i As Integer
Dim aFeatArr As Variant
Dim sAxis As String
For i = 0 To UBound(aFeatArrs)
aFeatArr = aFeatArrs(i, 0)
sAxis = aFeatArrs(i, 1)
Dim oFeat As Variant
For Each oFeat In aFeatArr
If oFeat.Suppressed = False Then
Dim oPoint As SketchPoint
Set oPoint = oFeat.Sketches(1).SketchPoints(1)
Dim oIntent2 As GeometryIntent
Set oIntent2 = oCompDef.CreateGeometryIntent(oPoint)
Dim oModelPoint As Point
Set oModelPoint = oIntent2.Point
Dim oTextPosH As Point
Dim oTextPosV As Point
Dim oLinModelDimDef As LinearModelDimensionDefinition
Dim oLinModelDim As LinearModelDimension
' die letzte verwendete Textposision, damit die nächste berechnet werden kann
Dim oTextPos_H1_H As Point '
Dim oTextPos_H1_V As Point
Dim oTextPos_H2_H As Point
Dim oTextPos_H2_V As Point
Dim oTextPos_T_H As Point
Dim oTextPos_T_V As Point
'Dim sNameParts() As String
sNameParts = Split(oFeat.Name, "_")
'Dim sName As String
sName = UCase(Left(sNameParts(UBound(sNameParts)), InStr(sNameParts(UBound(sNameParts)), ":") - 1))
Select Case sName
Case "H1":
Set oAnnoPlaneDef = oAnnoPlaneDef_hoehe1
If sAxis = "X" Then
'horizontal
If oTextPos_H1_H Is Nothing Then
Set oTextPos_H1_H = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, oModelPoint.Y, oModelPoint.Z + 10)
Else
Set oTextPos_H1_H = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, oModelPoint.Y, oTextPos_H1_H.Z + 10)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_H1_H, kHorizontalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
ElseIf sAxis = "Z" Then
'vertical
If oTextPos_H1_V Is Nothing Then
Set oTextPos_H1_V = oApp.TransientGeometry.CreatePoint(-oModelPoint.X - 10, oModelPoint.Y, oModelPoint.Z / 2)
Else
Set oTextPos_H1_V = oApp.TransientGeometry.CreatePoint(oTextPos_H1_V.X - 10, oModelPoint.Y, oModelPoint.Z / 2)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_H1_V, kVerticalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
End If
Case "H2":
Set oAnnoPlaneDef = oAnnoPlaneDef_hoehe2
If sAxis = "X" Then
'horizontal
If oTextPos_H2_H Is Nothing Then
Set oTextPos_H2_H = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, oModelPoint.Y, oModelPoint.Z + 10)
Else
Set oTextPos_H2_H = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, oModelPoint.Y, oTextPos_H2_H.Z + 10)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_H2_H, kHorizontalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
ElseIf sAxis = "Z" Then
'vertical
If oTextPos_H2_V Is Nothing Then
Set oTextPos_H2_V = oApp.TransientGeometry.CreatePoint(-oModelPoint.X - 10, oModelPoint.Y, oModelPoint.Z / 2)
Else
Set oTextPos_H2_V = oApp.TransientGeometry.CreatePoint(oTextPos_H2_V.X - 10, oModelPoint.Y, oModelPoint.Z / 2)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_H2_V, kVerticalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
End If
Case "T":
Set oAnnoPlaneDef = oAnnoPlaneDef_tiefe
If sAxis = "Y" Then
'horizontal
If oTextPos_T_H Is Nothing Then
Set oTextPos_T_H = oApp.TransientGeometry.CreatePoint(-oModelPoint.X + 10, oModelPoint.Y / 2, oModelPoint.Z)
Else
Set oTextPos_T_H = oApp.TransientGeometry.CreatePoint(oTextPos_T_H.X + 10, oModelPoint.Y / 2, oModelPoint.Z)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_T_H, kHorizontalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
ElseIf sAxis = "X" Then
'vertical
If oTextPos_T_V Is Nothing Then
Set oTextPos_T_V = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, -oModelPoint.Y - 10, oModelPoint.Z)
Else
Set oTextPos_T_V = oApp.TransientGeometry.CreatePoint(oModelPoint.X / 2, oTextPos_T_V.Y - 10, oModelPoint.Z)
End If
Set oLinModelDimDef = oLinModelDims.CreateDefinition(oIntent1, oIntent2, oAnnoPlaneDef, oTextPos_T_V, kVerticalDimensionType)
Set oLinModelDim = oLinModelDims.Add(oLinModelDimDef)
dTextOffset = oLinModelDimDef.Text.Size * 2
End If
End Select
End If
Next
Next
End Sub
Private Sub AddToArray(ByVal oFeat As iFeature, ByVal oCompDef As ComponentDefinition, ByVal sAxis As String, ByRef aArray() As Variant)
Dim oPoint1 As SketchPoint
Set oPoint1 = oFeat.Sketches(1).SketchPoints(1)
Dim oIntent1 As GeometryIntent
Set oIntent1 = oCompDef.CreateGeometryIntent(oPoint1)
If (Not Not aArray) = 0 Then
ReDim Preserve aArray(0 To 0)
Else
Dim oItem As Variant 'iFeature
For Each oItem In aArray
Dim oPoint2 As SketchPoint
Set oPoint2 = oItem.Sketches(1).SketchPoints(1)
Dim oIntent2 As GeometryIntent
Set oIntent2 = oCompDef.CreateGeometryIntent(oPoint2)
If sAxis = "X" Then
If oIntent1.Point.X = oIntent2.Point.X Then
Exit Sub
End If
ElseIf sAxis = "Y" Then
If oIntent1.Point.Y = oIntent2.Point.Y Then
Exit Sub
End If
Else
If oIntent1.Point.Z = oIntent2.Point.Z Then
Exit Sub
End If
End If
Next
ReDim Preserve aArray(UBound(aArray) + 1)
End If
Set aArray(UBound(aArray)) = oFeat
End Sub
Sub BubbleSort(ByRef MyArray() As Variant, sAxis As String)
'Sorts a one-dimensional VBA array from smallest to largest
'using the bubble sort algorithm.
Dim i As Long, j As Long
Dim Temp As Variant
For i = LBound(MyArray) To UBound(MyArray) - 1
For j = i + 1 To UBound(MyArray)
If sAxis = "X" Then
If Abs(MyArray(i).Sketches(1).OriginPointGeometry.X) > Abs(MyArray(j).Sketches(1).OriginPointGeometry.X) Then
Set Temp = MyArray(j)
Set MyArray(j) = MyArray(i)
Set MyArray(i) = Temp
End If
ElseIf sAxis = "Y" Then
If Abs(MyArray(i).Sketches(1).OriginPointGeometry.Y) > Abs(MyArray(j).Sketches(1).OriginPointGeometry.Y) Then
Set Temp = MyArray(j)
Set MyArray(j) = MyArray(i)
Set MyArray(i) = Temp
End If
Else
If Abs(MyArray(i).Sketches(1).OriginPointGeometry.Z) > Abs(MyArray(j).Sketches(1).OriginPointGeometry.Z) Then
Set Temp = MyArray(j)
Set MyArray(j) = MyArray(i)
Set MyArray(i) = Temp
End If
End If
Next j
Next i
End Sub
Foren auf CAD.de (alle Foren)
| 
