Attribute VB_Name = "GetSolidBoundary_v1"
Option Explicit
'------------------------------------------------------------------------------
'---------------------------GetSolidBoundary v1.0---------------------------
'------------------------------------------------------------------------------
'
'Author:    Daniel Frauenrath
'Mail:      daniel.frauenrath@gmx.com
'Release:   14.04.2010
'Version:   1.0
'
'********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Beschreibung / Discription>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'********************************************************************************
'DE:
'
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'EN:
'
'*********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Veränderungen / Change log>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'*********************************************************************************
'Autor:             Datum:          Zeile:     Modul:       Anmerkung:
'---------------------------------------------------------------------------------
'
'**********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<globale Variablen>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'**********************************************************************************
'
'
'**********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Hauptmakro (CATMain)>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'**********************************************************************************
Sub CATMain()

'****Deklarationen
    Dim intDocObj As Document
    Dim intWindowsObj As Windows
    Dim intObjTypeStr As String
    Dim intSelObj As Object 'Selection
    Dim intSelFilterStr(0)
    Dim intSelStateStr As String
    Dim intPartObj As Part
    Dim intRefObj As Reference
    Dim intHybBodiesObj As HybridBodies
    Dim intHybBodyObj As HybridBody
    Dim intHybShapeFacObj As HybridShapeFactory
    Dim intHybBoundaryObj As HybridShapeBoundary
    Dim intSPAWorkbenchObj As Workbench
    Dim intMeasurableObj As Measurable
    

'****Abfrage Dokumente
    Set intWindowsObj = CATIA.Windows
    If intWindowsObj.Count = 0 Then
        MsgBox "Es ist kein Dokument geladen!" + Chr(10) + "Das Makro kann nicht ausgeführt werden und wird beendet!", vbCritical, "Keine Dokument geladen"
        Exit Sub
    End If
    Set intDocObj = CATIA.ActiveDocument
    intObjTypeStr = TypeName(intDocObj)
    If intObjTypeStr <> "PartDocument" Then
        MsgBox "Das aktive Dokument ist kein PartDocument!" + Chr(10) + "Das Makro kann nicht ausgeführt werden!", _
                vbCritical + vbOKOnly, "Falscher Dokumententyp"
        Exit Sub
    End If
    intObjTypeStr = ""
    
'***Selektion erstellen
    Set intSelObj = intDocObj.Selection
    intSelObj.Clear
    
    intSelFilterStr(0) = "Face"
    'MsgBox "Bitte wählen Sie eine Fläche aus" + Chr(10) + "Die Fläche dient als Referenz für eine neu erzeugte Boundary" + Chr(10) + _
            "Der Flächeninhalt der Fläche wird ermittelt" + Chr(10) + Chr(10) + "ESC bricht die Selektion sowie das Makro ab!", vbInformation, "Bitte Fläche selektieren"
            
    intSelStateStr = intSelObj.SelectElement2(intSelFilterStr, "Bitte Fläche selektieren / ESC zum Abbrechen", False)
    
    If intSelStateStr <> "Normal" Then
        MsgBox "Die haben die Selektion abgebrochen!" + Chr(10) + "Das Makro wird beendet", vbInformation, "ABBRUCH DURCH ANWENDER"
        Exit Sub
    End If
    
'***Referenz erzeugen
    Set intPartObj = intDocObj.Part
    Set intRefObj = GetTheReference(intSelObj.Item(1).Value, intPartObj)
    
    If intRefObj Is Nothing Then
        Exit Sub
    End If
    
    'intSelObj.Clear
    
'***Neues geometrisches Set anlegen
    Set intHybBodiesObj = intPartObj.HybridBodies
    Set intHybBodyObj = intHybBodiesObj.Add
    
    intHybBodyObj.Name = "__FLAECHENABLEITUNG"
    
'***Boundary erstellen
    Set intHybShapeFacObj = intPartObj.HybridShapeFactory
    Set intHybBoundaryObj = intHybShapeFacObj.AddNewBoundaryOfSurface(intRefObj)
    intHybBodyObj.AppendHybridShape intHybBoundaryObj
    
'***Fläche messen
    Set intSPAWorkbenchObj = intDocObj.GetWorkbench("SPAWorkbench")
    Set intMeasurableObj = intSPAWorkbenchObj.GetMeasurable(intSelObj.Item(1).Value)

    MsgBox ("Flächeninhalt:" + Chr(9) + ConvertAreaValue(intMeasurableObj.Area))
    
'***Part Updaten
    intPartObj.Update


End Sub


'********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<GetTheReference>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'********************************************************************************
Private Function GetTheReference(ByVal uebSelObj As Object, ByVal uebPartObj As Part) As Reference

    '**Deklarationen
    Dim intBRepStrRaw() As String
    Dim intBRepStrSemi() As String
    Dim intBrepStr As String
    Dim intModelElementObj As ModelElement
    Dim intInternalNameStr As String
    
    On Error Resume Next

        intBRepStrRaw = Split(uebSelObj.Name, "Selection_")
        Set intModelElementObj = uebSelObj.Parent.GetItem("ModelElement")
        
        intInternalNameStr = intModelElementObj.InternalName
        
        intBRepStrSemi = Split(intBRepStrRaw(1), intInternalNameStr & "_ResultOUT")
        intBrepStr = intBRepStrSemi(0) & "WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    
        
        Set GetTheReference = uebPartObj.CreateReferenceFromBRepName(intBrepStr, uebSelObj.Parent)
        
        If Err.Number <> 0 Then
            Err.Clear
            intBRepStrSemi = Split(intBRepStrRaw(1), intInternalNameStr)
            intBrepStr = intBRepStrSemi(0) & intInternalNameStr & intBRepStrSemi(1) & "WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
            Set GetTheReference = uebPartObj.CreateReferenceFromBRepName(intBrepStr, uebSelObj.Parent)
            If Err.Number <> 0 Then
                Box = MsgBox("Die Referenz konnte nicht erstellt werden" + Chr(10) + _
                            "Das Makro wird beendet", vbExclamation, "Fehler")
                Set GetTheReference = Nothing
                Exit Function
            End If
        End If
        
    On Error GoTo 0

End Function


'********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<ConvertAreaValue>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'********************************************************************************
Private Function ConvertAreaValue(ByVal uebAreaValueDbl As Double) As String

    ConvertAreaValue = CStr(Round(uebAreaValueDbl * 1000000, 2)) & " mm²"

End Function


