Code:
Sub CATMain() Dim oCATIA As Application
' ===== Check if CATIA is open >>>>>
On Error Resume Next
Set oCATIA = catia
If Err.Number <> 0 Then
MsgBox "Could Not Get CATIA Application, Exiting Sub."
Exit Sub
End If
On Error GoTo 0
' <<<<< Check if CATIA is open =====
' ===== Get 1./2. Part >>>>>
Dim oPartDocument As PartDocument
Set oPartDocument = Get_PartDocument
Dim oRootProduct As ProductDocument
' <<<<< Get 1./2. Part =====
If Not oPartDocument Is Nothing Then
On Error Resume Next
Set oRootProduct = oCATIA.ActiveDocument
If Err.Number <> 0 Then
MsgBox "The Active Document In The Session Is Not An Assembly, Exiting Sub."
Exit Sub
End If
On Error GoTo 0
Make_RootNode_Active
End If
Dim RootGroups As Groups
Set RootGroups = oCATIA.ActiveDocument.Product.GetTechnologicalObject("Groups")
Dim oGroup1 As Group
Set oGroup1 = RootGroups.AddFromSel
CreateGroupFromSelection oGroup1
Dim oGroup2 As Group
Set oGroup2 = RootGroups.AddFromSel
CreateGroupFromSelection oGroup2
Dim oGroup3 As Group
Set oGroup3 = RootGroups.AddFromSel
' Dim MaxDistance As Double
' MaxDistance = GetDistanceBetweenGroups(oGroup1, oGroup2, oGroup3, True)
' MsgBox "Max Distance is : " & vbCrLf & MaxDistance & "mm" '& vbCrLf & MaxDistance / 25.4 & "in"
Dim MinDistance As Double
MinDistance = GetDistanceBetweenGroups(oGroup1, oGroup2, oGroup3, False)
MsgBox "Min Distance is : " & vbCrLf & MinDistance & "mm" '& vbCrLf & MinDistance / 25.4 & "in"
RootGroups.Remove oGroup1
RootGroups.Remove oGroup2
RootGroups.Remove oGroup3
End Sub
Private Function GetDistanceBetweenGroups(iGroup1 As Group, iGroup2 As Group, iGroup3 As Group, Max As Boolean) As Double
Dim dMaximum As Double
If Max = True Then
dMaximum = 0
Else
dMaximum = 1000000000
End If
Dim iOuter As Integer
Dim iInner As Integer
Dim oProduct1 As Product
Dim oProduct2 As Product
Dim RootDistances As Distances
Set RootDistances = catia.ActiveDocument.Product.GetTechnologicalObject("Distances")
Dim oDistance As Distance
For iOuter = 1 To iGroup1.CountExtract
Set oProduct1 = iGroup1.ItemExtract(iOuter)
iGroup3.AddExplicit oProduct1
For iInner = 1 To iGroup2.CountExtract
Set oProduct2 = iGroup2.ItemExtract(iInner)
iGroup3.AddExplicit oProduct2
Set oDistance = RootDistances.Add
oDistance.FirstGroup = iGroup3
oDistance.Compute
If (oDistance.IsDefined = 1) Then
If Max = True Then
If (oDistance.Value > dMaximum) Then
dMaximum = oDistance.Value
End If
Else
If (oDistance.Value < dMaximum) Then
dMaximum = oDistance.Value
End If
End If
End If
' RootDistances.Remove oDistance
' iGroup3.RemoveExplicit 2
Next
iGroup3.RemoveExplicit 1
Next
'X = RootDistances.Count
RootDistances.Item(RootDistances.Count).Name = Round(oDistance.Value, 3) & "mm: " & oProduct1.Name & " <-> " & oProduct2.Name
GetDistanceBetweenGroups = dMaximum
End Function
Private Sub CreateGroupFromSelection(iGroup As Group)
Dim ProductArray() As Product
ProductArray = MultiSelection("Product")
Dim iIndex As Integer
Dim oProduct As Product
For iIndex = 0 To UBound(ProductArray)
Set oProduct = ProductArray(iIndex).Value
iGroup.AddExplicit oProduct
Next
End Sub
Private Sub Make_RootNode_Active()
Dim oSelection As Selection
If TypeName(catia.ActiveDocument) = "ProductDocument" Then
Set oSelection = catia.ActiveDocument.Selection
oSelection.Clear
oSelection.Add catia.ActiveDocument.Product
AppActivate ("CATIA V5") 'Activate the catia window
SendKeys "c:" & "FrmActivate" & Chr(13), True
End If
oSelection.Clear
Set oSelection = Nothing
End Sub
Private Function Get_PartDocument() As PartDocument
Dim oCATIA As Application
Dim oDocument As Document
Dim oSelection As Selection
Dim oPart As Part
Set oCATIA = catia
Set oDocument = oCATIA.ActiveDocument
Set oSelection = oDocument.Selection
oSelection.Clear
'---------------------------------------------------'
If (InStr(oDocument.Name, ".CATPart")) = 0 Then
oSelection.Search ("type=Part,in")
On Error Resume Next
Set oPart = oSelection.FindObject("CATIAPart")
If Err.Number <> 0 Then
oSelection.Clear
Exit Function
End If
On Error GoTo 0
Else
Set oPart = oDocument.Part
End If
oSelection.Clear
'---------------------------------------------------'
Set Get_PartDocument = oPart.Parent
Set oPart = Nothing
Set oSelection = Nothing
Set oDocument = Nothing
Set oCATIA = Nothing
End Function
Private Function MultiSelection(sSelectType As String)
Dim Item() As AnyObject
Dim oPartDocument As PartDocument
Dim oSelection 'As Selection
Dim sStatus As String
Dim sInputObjectType(0)
Dim oReference As Reference
Dim iIndex
Set oSelection = catia.ActiveDocument.Selection
oSelection.Clear
sInputObjectType(0) = sSelectType
sStatus = oSelection.SelectElement3(sInputObjectType, "Select a " & sSelectType, True, CATMultiSelTriggWhenUserValidatesSelection, True)
If ((sStatus = "Cancel") Or (sStatus = "Undo")) Then
oSelection.Clear
Exit Function
End If
If oSelection.Count2 > 0 Then
For iIndex = 1 To oSelection.Count2
ReDim Preserve Item(iIndex - 1)
Set Item(iIndex - 1) = oSelection.Item2(iIndex)
Next
End If
MultiSelection = Item
oSelection.Clear
Set oReference = Nothing
Set oSelection = Nothing
End Function
Foren auf CAD.de
| 
ist die Abstände im 3D darstellen zu lassen nicht möglich (oder über extreme Umwege)
)
