Attribute VB_Name = "Module2"
' Makro:        Measure_Surface
' Version:      1.0
' Catia Level:  V5R19
' UIL:          English (User Interface Language)
' Autor:        Christian Obholzer
' E-Mail:       ch.obholzer@aon.at
' Erstellt:     27.03.2011
' Zweck:        Es wird das Abstandsmaß in 3er Schritten geändert und die Flächeninhalte nach Excel exportiert
'-----------------------------------------------------------------------------------
' Änderungen:   Datum, Name
'               Hier wird die Änderung angegeben
'               Datum, Name
'               Hier wird die Änderung angegeben
'-----------------------------------------------------------------------------------

Option Explicit
    
Sub CATMain()

    '***Deklarationen
    Dim objWindows As Windows
    Dim objDoc As Document
    Dim strTyp As String
    Dim objPart As Part
    Dim objSel As Object
    Dim objParameters As Parameters
    Dim GeoSets As HybridBodies
    Dim GeoSet As HybridBody
    Dim Skizzen As Sketches
    Dim Sketch_Grundform As Sketch
    Dim Sketch_Mitte_unten As Sketch
    Dim Constraints As Constraints
    Dim Constraint_Grundform As Constraint
    Dim Constraint_Mitte_unten As Constraint
    Dim objExcel As Object
    Dim WB As Workbook
    Dim intI As Integer
    Dim intJ As Integer
    Dim intK As Integer
    Dim intZeile As Integer
    
    '***Fehlerroutine einschalten
    On Error GoTo Fehler

    '***Abfrage nach geöffnetem Dokument
    Set objWindows = CATIA.Windows
    If objWindows.Count = 0 Then
        MsgBox "Es ist kein Dokument geöffnet." & vbNewLine & _
        "Das Makro kann nicht ausgeführt werden und wird beendet.", vbCritical + vbOKOnly, "Kein Dokument offen"
        Exit Sub
    End If

    '***Auslesen der Dokumentart
    Set objDoc = CATIA.ActiveDocument
    strTyp = TypeName(objDoc)
    If strTyp <> "PartDocument" Then
        MsgBox "Dieses Dokument ist kein Part." & vbNewLine & _
        "Das Makro kann nicht ausgeführt werden und wird beendet.", vbCritical + vbOKOnly, "Falscher Dokumententyp"
        Exit Sub
    End If
    
    Set objPart = objDoc.Part
    Set objSel = objDoc.Selection
    '***Vorselektion löschen um das Ergebnis nicht zu verfälschen
    objSel.Clear
    Set objParameters = objPart.Parameters
    
    '***Skizzen ansprechen
    Set GeoSets = objPart.HybridBodies
    Set GeoSet = GeoSets.Item("Konstruktionsskizzen")
    Set Skizzen = GeoSet.HybridSketches
    Set Sketch_Grundform = Skizzen.Item("Grundform")
    Set Sketch_Mitte_unten = Skizzen.Item("Mitte_unten")

    '***Constraint "Hoehe_Grundform" ansprechen
    Set Constraints = Sketch_Grundform.Constraints
    Set Constraint_Grundform = Constraints.Item("Hoehe_Grundform")
    
    '***Constraint "Hoehe_Mitte_unten" ansprechen
    Set Constraints = Sketch_Mitte_unten.Constraints
    Set Constraint_Mitte_unten = Constraints.Item("Hoehe_Mitte_unten")
    
    '***Excel starten
    Set objExcel = CreateObject("Excel.Application")
    '***Excel sichtbar schalten
    objExcel.Application.Visible = True
    '***Datei erstellen
    Set WB = objExcel.Workbooks.Add

    '***Überschrift eintragen
    objExcel.Cells(1, 1).Value = "Parameter auslesen"
    '***Schriftart: Fett
    objExcel.Cells(1, 1).Font.Bold = True
    '***Schriftfarbe: Rot
    objExcel.Cells(1, 1).Font.Color = -16776961
    '***Schriftgröße: 16
    objExcel.Cells(1, 1).Font.Size = 16
    '***Schrifttyp: Kursiv
    objExcel.Cells(1, 1).Font.Italic = True
    '***Überschrift unterstreichen
    objExcel.Cells(1, 1).Font.Underline = xlUnderlineStyleSingle
    '***Zellen verbinden
    objExcel.Range("A1:B1").MergeCells = True
    '***Zellenausrichtung Horizontal
    objExcel.Range("A1:B1").HorizontalAlignment = xlCenter
    '***Zellenausrichtung Vertikal
    objExcel.Range("A1:B1").VerticalAlignment = xlBottom
    '***Spaltenbreite
    objExcel.Columns("A:A").ColumnWidth = 32

    '***Überschrift der Unterkategorie eintragen
    objExcel.Cells(5, 1).Value = "Parametername"
    '***Schriftart: Fett
    objExcel.Cells(5, 1).Font.Bold = True
    '***Überschrift der Unterkategorie eintragen
    objExcel.Cells(5, 2).Value = "Wert"
    '***Schriftart: Fett
    objExcel.Cells(5, 2).Font.Bold = True
    
    '***Schleife in 3er Schritte abarbeiten
    For intI = 3 To Constraint_Grundform.Dimension.Value - 1 Step 3
        '***Maßzahl ändern
        Constraint_Mitte_unten.Dimension.Value = intI
        
        objPart.Update
        
        For intJ = 1 To objParameters.Count
            '***Fehlerroutine ausschalten
            On Error Resume Next
            
            If objParameters.Item(intJ).ValueEnum <> "CstAttr_Mode_Constrained" And objParameters.Item(intJ).ValueEnum <> "true" And objParameters.Item(intJ).ValueEnum <> "false" Then
                objSel.Clear
                objSel.Add objParameters.Item(intJ)
                '***Parameter/Messung updaten
                CATIA.StartCommand "Local Update"
                objSel.Clear
            End If
        Next
        
        '***Fehlerroutine einschalten
        On Error GoTo Fehler
            
        '***Performanceerhöhung der Suche
        CATIA.HSOSynchronized = False
        '***Parameter suchen
        objSel.Search "Knowledgeware.Parameter.Name !=Origin*"
        CATIA.HSOSynchronized = True

        For intK = 1 To objSel.Count
            '***Parameternamen eintragen
            objExcel.Cells(5 + intZeile + intK, 1).Value = objSel.Item(intK).Value.Name & " Update_" & intI / 3
            
            '***Werte eintragen
            objExcel.Cells(5 + intZeile + intK, 2).Value = objSel.Item(intK).Value.Value
        Next
        
        '***Zeilenanzahl definieren
        intZeile = intZeile + 6
        
    Next
    
    '***Meldung an User
    MsgBox "Makro wurde erfolgreich beendet.", vbInformation + vbOKOnly, "Makro erfolgreich beendet"

Exit Sub

'***Fehlerbehandlung: Ausgabe der Fehlernummer und Fehlerbeschreibung
Fehler:
    MsgBox "Fehlernummer: " & Err.Number & vbNewLine & _
    "Fehlerbeschreibung: " & Err.Description, vbCritical + vbOKOnly, "Fehler"
    
End Sub
