Attribute VB_Name = "PartNr_und_Blechdicke_auslesen"
' Makro:        PartNr_und_Blechdicke_auslesen
' Version:      1.0
' Catia Level:  V5R19
' UIL:          English (User Interface Language)
' Autor:        Christian Obholzer
' E-Mail:       ch.obholzer@aon.at
' Erstellt:     28.07.2011
' Zweck:        Es werden alle PartNumber und Blechdicken von Parts in Excel importiert
'-----------------------------------------------------------------------------------
' Ä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 objDocuments As Documents
    Dim objExcel As Object
    Dim WB As Workbook
    Dim objSel As Object
    Dim intZeile As Integer
    Dim intI As Integer
    Dim strPartNumber As String

    '***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 = "DrawingDocument" Then
        MsgBox "Dieses Dokument ist ein Drawing." + vbNewLine + _
        "Das Makro kann nicht ausgeführt werden und wird beendet.", vbCritical + vbOKOnly, "Falscher Dokumententyp"
        Exit Sub
    End If
    
    Set objDocuments = CATIA.Documents

    '***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 = "PartNumber und Blechdicke 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:B").ColumnWidth = 40

    '***Überschrift der Unterkategorie eintragen
    objExcel.Cells(3, 1).Value = "PartNumber"
    '***Schriftart: Fett
    objExcel.Cells(3, 1).Font.Bold = True
    '***Überschrift der Unterkategorie eintragen
    objExcel.Cells(3, 2).Value = "Blechdicke"
    '***Schriftart: Fett
    objExcel.Cells(3, 2).Font.Bold = True

    Set objSel = objDoc.Selection
    '***Vorselektion löschen um das Ergebnis nicht zu verfälschen
    objSel.Clear
    
    '***Initialwert festlegen
    intZeile = 4
    
    For intI = 1 To objDocuments.Count
        '***alle Parts bearbeiten
        If (Right(objDocuments.Item(intI).Name, 7) = "CATPart") Then
            '***PartNumber ermitteln
            strPartNumber = objDocuments.Item(intI).Product.PartNumber
        
            '***PartNumber eintragen
            objExcel.Cells(intZeile, 1).Value = strPartNumber
            
            '***Fehlerroutine ausschalten
            On Error Resume Next
            
            '***Blechdicke eintragen
            objExcel.Cells(intZeile, 2).Value = objDocuments.Item(intI).Part.Parameters.Item(strPartNumber & "\Sheet Metal Parameter.1\Thickness").Value
            
            If objExcel.Cells(intZeile, 2).Value = "" Then
                objExcel.Cells(intZeile, 2).Value = "Dieses Part enthält keinenBlechparameter"
            End If
            
            '***Fehlerroutine einschalten
            On Error GoTo Fehler
            
            '***Zeilen hochzählen
            intZeile = intZeile + 1
        End If
    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"
    
    '***Excel beenden
    objExcel.Application.Quit

End Sub
