VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Punktkoordinaten_auslesen 
   Caption         =   "Punktkoordinaten auslesen"
   ClientHeight    =   3825
   ClientLeft      =   45
   ClientTop       =   375
   ClientWidth     =   5535
   OleObjectBlob   =   "Punktkoordinaten_auslesen.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "Punktkoordinaten_auslesen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Makro:        Punktkoordinaten_auslesen
' Version:      1.1
' Catia Level:  V5R19
' UIL:          English (User Interface Language)
' Autor:        Christian Obholzer
' E-Mail:       ch.obholzer@aon.at
' Erstellt:     06.10.2010
' Zweck:        Es werden die Koordinaten der Punkte in ein Excelfile ausgelesen
'-----------------------------------------------------------------------------------
' Änderungen:   17.11.2010, Christian Obholzer
'               Fortschrittsbalken hinzugefügt
'               Datum, Name
'               Hier wird die Änderung angegeben
'-----------------------------------------------------------------------------------

Option Explicit

Private Sub cmd_Koordinaten_auslesen_Click()

    '***Deklarationen
    Dim objWindows As Windows
    Dim objDoc As Document
    Dim strTyp As String
    Dim objPart As Part
    Dim objSel As Object
    Dim strSel As String
    Dim objExcel As Object
    Dim WB As Workbook
    Dim intI As Integer
    Dim Coordinates(2)
    Dim strSearchFilter(0)
    strSearchFilter(0) = "HybridBody"
    Dim dblLaenge As Double
    Dim dblSchritt As Double

    '***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 objSel = objDoc.Selection
    '***Vorselektion löschen um das Ergebnis nicht zu verfälschen
    objSel.Clear
    
    If Me.chk_GeoSet.Value = False Then
        '***Performanceerhöhung der Suche
        CATIA.HSOSynchronized = False
        '***Element suchen
        objSel.Search ("Part Design.Point.Name=" & Me.txt_Punktname.Text & ",all")
        CATIA.HSOSynchronized = True
    Else
        '***Geometrisches Set auswählen
        strSel = objSel.SelectElement2(strSearchFilter, "Wählen Sie das Geometrische Set mit den Punkten aus", False)
        '***Auswertung der Selektion
        If strSel = "Normal" Then
            '***Performanceerhöhung der Suche
            CATIA.HSOSynchronized = False
            '***Element suchen
            objSel.Search ("Part Design.Point ,sel")
            CATIA.HSOSynchronized = True
        Else
            MsgBox "Abbruch der Selektion durch den User." & vbNewLine & _
            "Das Makro wird beendet.", vbExclamation + vbOKOnly, "Abbruch der Selektion"
            objSel.Clear
            Exit Sub
        End If
    End If
        
    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 = "Koordinaten 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 = "Punktname"
        
        '***Ü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
        
        '***Schriftart: Fett
        objExcel.Range("A1:H3").Font.Bold = True
        '***Zellenausrichtung Horizontal
        objExcel.Range("B3:D3").HorizontalAlignment = xlCenter
        objExcel.Range("B3:D6200").HorizontalAlignment = xlCenter
        '***Zellenausrichtung Vertikal
        objExcel.Range("B3:D6200").VerticalAlignment = xlCenter

        '***Fortschrittbalken einblenden
        Me.lbl_Fortschrittsbalken.Visible = True
        '***Startbreite des Fortschrittbalkens
        dblLaenge = 0
        '***Schrittbreite pro Aktualisierung
        dblSchritt = Me.lbl_Fortschrittsbalken.Width / objSel.Count
        For intI = 1 To objSel.Count
            '***Berechnung der Breite des Fortschrittbalkens
            dblLaenge = dblLaenge + dblSchritt
            Me.lbl_Fortschrittsbalken.Width = dblLaenge
            '***Berechung der Prozente für den Fortschrittstext
            Me.lbl_Fortschrittstext.Caption = Format(intI / objSel.Count, "0 %")
            
            '***Messpunktname eintragen
            objExcel.Cells(3 + intI, 1).Value = objSel.Item(intI).Value.Name
            '***Koordinaten eintragen
            objSel.Item(intI).Value.GetCoordinates 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)
        Next
        
        objSel.Clear
        '***Meldung an User
        MsgBox "Makro wurde erfolgreich beendet.", vbInformation + vbOKOnly, "Makro erfolgreich beendet"
        
        '***Fenster schließen
        Unload Me
    Else
        MsgBox "Es ist kein Punkt mit dem Namen " & Me.txt_Punktname & " vorhanden.", vbExclamation + vbOKOnly, "Kein Punkt 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

Private Sub cmd_Beenden_Click()
    
    '***Fenster schließen
    Unload Me

End Sub

Private Sub UserForm_Initialize()

    '***Wert der CheckBox festlegen
    Me.chk_GeoSet.Value = False

    '***Fortschrittsbalken ausblenden
    Me.lbl_Fortschrittsbalken.Visible = False

End Sub
