Attribute VB_Name = "Hole_Properties_auslesen"
' Makro:        Hole_Properties_auslesen
' Version:      1.1
' Catia Level:  V5R19
' UIL:          English (User Interface Language)
' Autor:        Christian Obholzer
' E-Mail:       ch.obholzer@aon.at
' Erstellt:     24.10.2010
' Zweck:        Es werden alle Hole Properties ausgelesen und in ein Excelfile geschrieben
'-----------------------------------------------------------------------------------
' Änderungen:   25.01.2010, Christian Obholzer
'               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 objExcel As Object
    Dim WB As Workbook
    Dim intI As Integer
    Dim Coordinates(2)
    Dim objHole As Hole
    Dim vntHole As Variant

    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 objSel = objDoc.Selection
    '***Vorselektion löschen um das Ergebnis nicht zu verfälschen
    objSel.Clear
    
    '***Performanceerhöhung der Suche
    CATIA.HSOSynchronized = False
    '***Element suchen
    objSel.Search "Part Design.Hole, all"
    CATIA.HSOSynchronized = True
        
    If objSel.Count > 0 Then
        '***Excel starten
        Set objExcel = CreateObject("Excel.Application")
        
        '***Excel sichtbar schalten
        objExcel.Application.Visible = True
        
        '***neue Arbeitsmappe hinzufügen
        Set WB = objExcel.Workbooks.Add
        
        '***Überschrift eintragen
        objExcel.Cells(1, 1).Value = "Hole Properties auslesen"
        '***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:D1").MergeCells = True
        '***Zellenausrichtung Horizontal
        objExcel.Range("A1:D1").HorizontalAlignment = xlCenter
        '***Zellenausrichtung Vertikal
        objExcel.Range("A1:D1").VerticalAlignment = xlBottom
        '***Spaltenbreite
        objExcel.Columns("A:A").ColumnWidth = 32
        
        '***Überschrift: Punktname eintragen
        objExcel.Cells(3, 1).Value = "Holename"
        
        '***Überschrift: X eintragen
        objExcel.Cells(3, 2).Value = "X"
        '***Spaltenbreite: 10
        objExcel.Columns("B:B").ColumnWidth = 10
        
        '***Überschrift: Y eintragen
        objExcel.Cells(3, 3).Value = "Y"
        '***Spaltenbreite: 10
        objExcel.Columns("C:C").ColumnWidth = 10
        
        '***Überschrift: Z eintragen
        objExcel.Cells(3, 4).Value = "Z"
        '***Spaltenbreite: 10
        objExcel.Columns("D:D").ColumnWidth = 10
        
        '***Überschrift: Durchmesser eintragen
        objExcel.Cells(3, 5).Value = "Durchmesser"
        '***Spaltenbreite: 20
        objExcel.Columns("E:E").ColumnWidth = 20
        
        '***Schriftart: Fett
        objExcel.Range("A1:H3").Font.Bold = True
        '***Zellenausrichtung Horizontal
        objExcel.Range("B3:E3").HorizontalAlignment = xlCenter
        objExcel.Range("B3:E6200").HorizontalAlignment = xlCenter
        '***Zellenausrichtung Vertikal
        objExcel.Range("B3:D6200").VerticalAlignment = xlCenter

        For intI = 1 To objSel.Count
        
            '***Holename eintragen
            objExcel.Cells(3 + intI, 1).Value = objSel.Item(intI).Value.Name
           
            Set objHole = objSel.Item(intI).Value
            
            '***wird benöigt um die Koordinaten auszulesen
            Set vntHole = objHole
            
            '***Koordinaten eintragen
            vntHole.GetOrigin Coordinates
            objExcel.Cells(3 + intI, 2).Value = Coordinates(0)
            objExcel.Cells(3 + intI, 3).Value = Coordinates(1)
            objExcel.Cells(3 + intI, 4).Value = Coordinates(2)
            
            Set objHole = objSel.Item(intI).Value
            '***Bohrungsdurchmesser eintragen
            objExcel.Cells(3 + intI, 5).Value = objHole.Diameter.Value
            
        Next
        
        objSel.Clear
        
    Else
        MsgBox "Es ist keine Bohrung vorhanden.", vbExclamation + vbOKOnly, "Keine Bohrung vorhanden"
        
    End If

Exit Sub

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