Code:
Option Explicit'****Globale Variablen*****
Dim opartDocument As PartDocument
Dim opart As Part
Dim oShapeFactory As ShapeFactory
Dim oHybridShapeFactory As HybridShapeFactory
Dim oHybridBodies As HybridBodies
Dim oHybridBody1 As HybridBody
Dim oSelection As Selection 'Selection
Dim oSelection2 As Object 'Selection für Option Explicit
Dim TheSPAWorkbench
Dim TheMeasurable
Dim orefExtrema As Reference
Dim oreferenceFace As Reference
Dim oHybridShapeBoundary As HybridShapeBoundary
'*******************************************************************************************
'This Macro will create m-Extrema on a selected Surface and split the Boundary with them****
'********************************************************************************************
Sub CATMain()
Set opartDocument = CATIA.ActiveDocument
If (InStr(opartDocument.Name, ".CATPart")) <> 0 Then 'Prüfen ob es sich um ein CATPart handelt
Set opart = opartDocument.Part
Set oSelection = opartDocument.Selection 'Initiliserung der Selection
opart.Update
End If
'*********************************************************************************************
'Der Benutzer wird aufgefordert eine Fläche von einer der vorgegebener Kategorie auszuwählen
'*********************************************************************************************
Dim sStatus As String
Set oHybridShapeFactory = opart.HybridShapeFactory
Set oSelection2 = oSelection
ReDim sFilter(0)
MsgBox ("Select a" & vbCrLf & Chr(13) & "Multi-Section-Surface" & vbCrLf & Chr(13) & "Offset" & vbCrLf & Chr(13) & "Blend" & vbCrLf & Chr(13) & "Sweep ")
sFilter(0) = "HybridShapeSurfaceExplicit"
sStatus = oSelection2.SelectElement2(sFilter, "select a face", False)
If (sStatus = "Cancel") Then
MsgBox (" Macro will Stop") 'Wenn die Selektion nicht ausgeführt wird oder abgebrochen wird
Exit Sub 'stopt das Makro
Else
'*********************************************************************************************
'Create Boundary on selected Surface
'Create Geosets (Helping_Line;Helping_Point and Extrema)
'*********************************************************************************************
Dim ABC As String
Set oreferenceFace = opart.CreateReferenceFromObject(oSelection.Item(1).Value)
Set oHybridShapeBoundary = oHybridShapeFactory.AddNewBoundaryOfSurface(oreferenceFace)
ABC = "Helping_Line"
Create_Geoset (ABC)
ABC = "Extrema"
Create_Geoset (ABC)
ABC = "Helping_Point"
Create_Geoset (ABC)
Set oHybridBody1 = oHybridBodies.Item("Helping_Line")
oHybridBody1.AppendHybridShape oHybridShapeBoundary
opart.Update
End If
'*********************************************************************************************
'******Count Edges of Boundary and Create Extract*********************************************
'*********************************************************************************************
oSelection.Clear
oSelection.Add oHybridShapeBoundary
oSelection.Search "Topology.CGMEdge,sel" 'sucht die Kanten der erstellten Boundary
'MsgBox oSelection.Count2 & " Edges are found from the selected face"
'*********************************************************************************************
'*********Hier kann eine Erweiterung auf m-Kanten erfolgen!!!!***************
'*********************************************************************************************
Dim m As Integer
If oSelection.Count2 = 4 Then 'Zähler der Kanten (Flächenkriterium = 4 Kanten)
m = oSelection.Count2 'm can be used for more than 4 Edges
Create_Extracts (m) 'Function Create_four_Extracts
Else
'löscht die bisherigen erstellten Geosets bei count != 4
MsgBox (" More or less than four Edges where found" & vbCrLf & Chr(13) & " Macro will Stop")
ABC = "Helping_Line"
Delete_Created_Geosets (ABC)
ABC = "Extrema"
Delete_Created_Geosets (ABC)
ABC = "Helping_Point"
Delete_Created_Geosets (ABC)
Exit Sub
End If
'*********************************************************************************************
'erstellt zwischen den Kanten 1/2 ; 2/3 ;3/4 ... 4/1 usw. jeweils einen Intersect
'*********************************************************************************************
Create_Intersects (m)
'*********************************************************************************************
'erstellt alle Kombinationsmöglichkeiten von Extrema [3^3] ,außer 0/0/0 = error
'*********************************************************************************************
Dim oHybridShapeExtremum1 As HybridShapeExtremum
Dim ohybridShapeD1 As HybridShapeDirection
Dim X, Y, Z As Integer
Dim GeomType As Integer
For X = -1 To 1 Step 1
For Y = -1 To 1 Step 1
For Z = -1 To 1 Step 1
If Not (X = 0 And Y = 0 And Z = 0) Then
Set ohybridShapeD1 = oHybridShapeFactory.AddNewDirectionByCoord(X, Y, Z)
Set oHybridShapeExtremum1 = oHybridShapeFactory.AddNewExtremum(oreferenceFace, ohybridShapeD1, 1)
Set oHybridBody1 = oHybridBodies.Item("Extrema")
oHybridBody1.AppendHybridShape oHybridShapeExtremum1
oHybridShapeExtremum1.Name = "Extrema." & CStr(X) & CStr(Y) & CStr(Z)
opart.Update
'Check the geometrical type of the shape
Set orefExtrema = opart.CreateReferenceFromObject(oHybridShapeExtremum1)
GeomType = oHybridShapeFactory.GetGeometricalFeatureType(orefExtrema) '=> Integer
'Check the integer geom type value and decide
Select Case GeomType
Case 0 'Unknown
oSelection.Clear
Set orefExtrema = oHybridShapeExtremum1
oSelection.Add orefExtrema ' lösche den Extrempunkt, da es sich nicht um einen Punkt handelt
oSelection.Delete
Case 1 'Point
Set orefExtrema = oHybridShapeExtremum1
Check_Point_Extrema 'Prüft ob es eine Übereinstimmung mit einem Intersect gibt
Case 2 'Curve
oSelection.Clear
Set orefExtrema = oHybridShapeExtremum1
oSelection.Add orefExtrema ' lösche den Extrempunkt, da er eine Kurve ist
oSelection.Delete
Case 3 'Line
oSelection.Clear
Set orefExtrema = oHybridShapeExtremum1
oSelection.Add orefExtrema ' lösche den Extrempunkt, da er eine Linie ist
oSelection.Delete
Case Else 'löscht alle Geosets
ABC = "Helping_Line"
Delete_Created_Geosets (ABC)
ABC = "Extrema"
Delete_Created_Geosets (ABC)
ABC = "Helping_Point"
Delete_Created_Geosets (ABC)
End Select
End If
Next
Next
Next
'*********************************************************************************************
'****************Delete the Geosets ( Helping_Line and Helping_Point)*************************
'*********************************************************************************************
ABC = "Helping_Line"
Delete_Created_Geosets (ABC)
ABC = "Helping_Point"
Delete_Created_Geosets (ABC)
'*********************************************************************************************
'****************Create a Geosets ( Boundary )***********************************************
'*********************************************************************************************
'ABC = "Boundary"
'Create_Geoset (ABC)
Create_sections_of_Boundary (m)
End Sub
'*********************************************************************************************
'****Sucht und erstellt ein Geoset mit einem Variablen Namen***
'****************************************************************
Sub Create_Geoset(ABC As String)
Dim Name As String
oSelection.Clear
Name = "CATGmoSearch.OpenBodyFeature.Name=" & CStr(ABC) & ",all"
oSelection.Search (Name) 'Variable Geoset suche
If oSelection.Count < 1 Then
Set oHybridBodies = opart.HybridBodies
Set oHybridBody1 = opart.HybridBodies.Add 'Erstellen eines Geosets
oHybridBody1.Name = CStr(ABC)
Else
Set oHybridBodies = opart.HybridBodies
Set oHybridBody1 = oHybridBodies.Item(CStr(ABC))
End If
End Sub
'*********************************************************************************************
'****Delete all Geometricalsets on cancel ****************************************************
'*********************************************************************************************
Sub Delete_Created_Geosets(ABC As String)
Dim Name2 As String
Name2 = CStr(ABC)
oSelection.Clear
Set oHybridBody1 = oHybridBodies.Item(Name2)
oSelection.Add oHybridBody1
oSelection.Delete
opart.Update
End Sub
'*********************************************************************************************
'****** Create Extracts from Boundary Edges *************************************************
'********************************************************************************************
Private Function Create_Extracts(m As Integer)
Dim n As Integer
Dim oreferenceLine As Reference
Dim ohybridShapeExtract As HybridShapeExtract
Dim ArrExtract() As String
For n = 1 To m
Set oreferenceLine = oSelection.Item(n).Value
Set ohybridShapeExtract = oHybridShapeFactory.AddNewExtract(oreferenceLine)
ohybridShapeExtract.PropagationType = 3 'keine tangenten- oder kurvenstetige Ableitung
ohybridShapeExtract.ComplementaryExtract = False '
ohybridShapeExtract.IsFederated = False
Set oHybridBody1 = oHybridBodies.Item("Helping_Line")
oHybridBody1.AppendHybridShape ohybridShapeExtract
ohybridShapeExtract.Name = "Ableitung." & CStr(n) 'rename
opart.Update
Next
End Function
'*********************************************************************************************
'Create m-Intersects between the Extracs of the Boundary**************************************
'**********************************************************************************************
Private Function Create_Intersects(m As Integer)
Dim t As Integer
Dim n As Integer
Dim orefIntersect1 As Reference
Dim orefIntersect2 As Reference
Dim oHybridShapeIntersection As HybridShapeIntersection
For n = 1 To m
If n < m Then
t = 1
Set oHybridBody1 = oHybridBodies.Item("Helping_Line")
Set orefIntersect1 = oHybridBody1.HybridShapes.Item("Ableitung." & CStr(n))
Set orefIntersect2 = oHybridBody1.HybridShapes.Item("Ableitung." & CStr(n + t))
Set oHybridShapeIntersection = oHybridShapeFactory.AddNewIntersection(orefIntersect1, orefIntersect2)
Set oHybridBody1 = oHybridBodies.Item("Helping_Point")
oHybridBody1.AppendHybridShape oHybridShapeIntersection
oHybridShapeIntersection.Name = "Int." & CStr(n)
opart.Update
Else
t = m - 1 'Intersect Between Extract m and 1
Set oHybridBody1 = oHybridBodies.Item("Helping_Line")
Set orefIntersect1 = oHybridBody1.HybridShapes.Item("Ableitung." & CStr(n))
Set orefIntersect2 = oHybridBody1.HybridShapes.Item("Ableitung." & CStr(n - t))
Set oHybridShapeIntersection = oHybridShapeFactory.AddNewIntersection(orefIntersect1, orefIntersect2)
Set oHybridBody1 = oHybridBodies.Item("Helping_Point")
oHybridBody1.AppendHybridShape oHybridShapeIntersection
oHybridShapeIntersection.Name = "Int." & CStr(n)
opart.Update
End If
Next
End Function
'***************************************************************************************
'*********If the Point Extrema has 0 mm to an Intersect keep it else delete ***********
'***************************************************************************************
Private Function Check_Point_Extrema()
Dim k As Integer
Dim orefIntersect1 As Reference
Dim MinimumDistance As Double 'Distance Between Intersect and Extrema
oSelection.Clear
Set oHybridBody1 = oHybridBodies.Item("Helping_Point")
oSelection.Add oHybridBody1
oSelection.Search ("Type=Point,sel")
k = oSelection.Count2
For k = oSelection.Count2 To 0 Step -1
If k = 0 Then
oSelection.Clear
oSelection.Add orefExtrema ' lösche den Extrempunkt, da es zu keiner Übereinstimmung mit einem Intersect gekommen ist
oSelection.Delete
Exit For
Else
Set orefIntersect1 = oSelection.Item(k).Value
Set TheSPAWorkbench = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")
Set TheMeasurable = TheSPAWorkbench.GetMeasurable(orefExtrema)
MinimumDistance = TheMeasurable.GetMinimumDistance(orefIntersect1)
Select Case MinimumDistance
Case 0
oSelection.Clear
oSelection.Add orefIntersect1 'löscht den Intersect,da er ein Extrema representiert
oSelection.Delete 'und keine doppelten Extrema erzeugen werden sollen
Exit Function
End Select
End If
Next
End Function
'*********************************************************************************************
'*********Create m-sections from Boundary on selected Surface*********************************
'*********************************************************************************************
Private Function Create_sections_of_Boundary(m As Integer)
Dim n As Integer
Dim t As Integer
oSelection.Clear
Set oHybridBody1 = oHybridBodies.Item("Extrema")
oSelection.Add oHybridBody1
oSelection.Search "Type=Point,sel"
For n = 1 To m Step 1
If n < m Then
t = 1
Set oHybridShapeBoundary = oHybridShapeFactory.AddNewBoundaryOfSurface(oreferenceFace)
oHybridBody1.AppendHybridShape oHybridShapeBoundary
oHybridShapeBoundary.From = oSelection.Item(n).Value
oHybridShapeBoundary.FromOrientation = 1
oHybridShapeBoundary.To = oSelection.Item(n + t).Value
oHybridShapeBoundary.ToOrientation = 1
opart.Update
Else
t = m - 1 'Boundary between first and last
Set oHybridShapeBoundary = oHybridShapeFactory.AddNewBoundaryOfSurface(oreferenceFace)
oHybridBody1.AppendHybridShape oHybridShapeBoundary
oHybridShapeBoundary.From = oSelection.Item(n).Value
oHybridShapeBoundary.FromOrientation = 1
oHybridShapeBoundary.To = oSelection.Item(n - t).Value
oHybridShapeBoundary.ToOrientation = 1
opart.Update
End If
Next
End Function
Foren auf CAD.de (alle Foren)
| 
