Code:
Sub CATMain()
'************************************************************************Dokument****
Dim oCatia As Application
Dim oPartDocument As PartDocument
Dim oSelection As Selection
Dim oPart As PartSet oPartDocument = Get_PartDocument
If oPartDocument Is Nothing Then
Exit Sub
End If
Set oPart = oPartDocument.Part
'********************************************************************HybridBodies****
Dim oHybridShapeFactory As HybridShapeFactory
Dim oHhybridShapePointCoord As HybridShapePointCoord
Dim oHybridBodies As HybridBodies
Dim oHybridBody As HybridBody
Dim oReference As Reference
Dim oHybridShapePointExplicit As HybridShapePointExplicit
'***************************************************Search HybridBodies and Count****
Set oSelection = CATIA.ActiveDocument.Selection
oSelection.Clear
oSelection.Search ("CATGmoSearch.OpenBodyFeature.Name=CenterOfGravity,all")
If oSelection.Count < 1 Then
Set oHybridBodies = oPart.HybridBodies
Set oHybridBody = oPart.HybridBodies.Add
oHybridBody.Name = "CenterOfGravity"
Else
Set oHybridBodies = oPart.HybridBodies
Set oHybridBody = oHybridBodies.Item("CenterOfGravity")
End If
oSelection.Clear
'*********************************************************************AddNewPoint****
Set oHybridShapeFactory = oPart.HybridShapeFactory
Set oHybridShapePointCoord = oHybridShapeFactory.AddNewPointCoord(0, 0, 0)
oHybridShapePointCoord.Compute
'*****************************************************Create Reference from Point****
Set oReference = oPart.CreateReferenceFromObject(oHybridShapePointCoord)
Set oHybridShapePointExplicit = oHybridShapeFactory.AddNewPointDatum(oReference)
oHybridShapePointExplicit.Compute
oHybridBody.AppendHybridShape oHybridShapePointExplicit
oHybridShapeFactory.DeleteObjectForDatum oReference
'**********************************************************************Selection*****
Set oSelection = CATIA.ActiveDocument.Selection
Set oPartDocument = CATIA.ActiveDocument
If (Instr(oPartDocument.Name,".CATPart"))<> 0 Then
Set oPart= oPartDocument.Part
Set oSelection = CATIA.ActiveDocument.Selection
Dim sStatus As String
Dim sFilter(0) as String
Msgbox "Select a Face "
sFilter(0) = "Face"
sStatus = oSelection.SelectElement2(sFilter, "select a face", False)
If (sStatus = "Cancel") Then
Exit Sub
'Hier Hänge ich 
oSelection.Item(1).Value.Name
End If
'************************************************************************Formula*****
Dim oRelations As Relations
Set oRelations = oPart.Relations
Dim oFormula As Formula
Set oFormula = oRelations.CreateFormula("Formula.1", "", oHybridShapePointExplicit, "centerofgravity('hier soll die selektierte Fläche stehen ') ")
oFormula.Rename "Gravity"
oSelection.Clear
oPart.Update
'*****************************************************************************Sub****
End Sub
'************************************************************************Function****
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
On Error Resume Next
Set oDocument = CATIA.ActiveDocument
If Err.Number <> 0 Then
MsgBox "There Is No Active Document In Teh Current Session, Exitting Script."
End If
On Error GoTo 0
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
MsgBox "A Part or Part Instance Must be Active." & vbLf & "Exiting The Script"
oSelection.Clear
Exit Function
End If
On Error GoTo 0
Else
Set oPart = oDocument.Part
End If
oSelection.Clear
'---------------------------------------------------'
Set Get_PartDocument = oPart.Parent
End Function
Foren auf CAD.de
| 
