Attribute VB_Name = "Modul1"
Option Explicit
'------------------------------------------------------------------------------
'---------------------------ImportExcelCellValue v1.0---------------------------
'------------------------------------------------------------------------------
'
'Author:    Daniel Frauenrath
'Mail:      daniel.frauenrath@gmx.com
'Release:   25.01.2010
'Version:   1.0
'
'********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Beschreibung / Discription>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'********************************************************************************
'DE: Importiert den Inhalt einer Excel-Zelle (vom Anwender selektiert) in ein neues
'    Textfeld der aktiven CATIA Ansicht
'
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'EN:
'
'*********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Veränderungen / Change log>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'*********************************************************************************
'Autor:             Datum:          Zeile:     Modul:       Anmerkung:
'---------------------------------------------------------------------------------
'
'**********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<globale Variablen>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'**********************************************************************************
Public CATIA As Object
'
'**********************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<<Hauptmakro (Main)>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'**********************************************************************************
Sub Main()

    '***Deklarationen
    Dim intUserSelRange As Range
    Dim intDoc As Object
    Dim intFensterWin As Object
    Dim intObjTypeStr As String
    Dim intSheets As Object
    Dim intSheet As Object
    Dim intViews As Object
    Dim intView As Object
    Dim intTexts As Object
    Dim intNewText As Object

    
    '***CATIA Object holen
    Set CATIA = GetCATIA
    If CATIA Is Nothing Then
        MsgBox "Das CATIA Object konnte nicht erzeugt werden!" + vbNewLine + "Das Makro wird beendet", vbCritical, "CATIA Objcet nicht gefunden"
    End If
    
    '***Abfrage Dokumente CATIA
    Set intFensterWin = CATIA.Windows
    If intFensterWin.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 intDoc = CATIA.ActiveDocument
    intObjTypeStr = TypeName(intDoc)
    If intObjTypeStr <> "DrawingDocument" Then
        MsgBox "Das aktive Dokument ist kein Zeichnung!" + Chr(10) + "Das Makro kann nicht ausgeführt werden!", _
                vbCritical + vbOKOnly, "Falscher Dokumententyp"
        Exit Sub
    End If
    intObjTypeStr = ""
    
    '***Excel Selektion
    Set intUserSelRange = SelectCell
    If intUserSelRange Is Nothing Then
        MsgBox "Sie haben die Selektion der Zelle abgebrochen!" + vbNewLine + "Das Makro wird beendet", vbExclamation, "Abbruch durch Anwender"
        Exit Sub
    End If
    
    '***Textfeld in CATIA erstellen und Text hinzufügen
    On Error Resume Next
        Set intDoc = CATIA.ActiveDocument
        Set intSheets = intDoc.Sheets
        Set intSheet = intSheets.ActiveSheet
        Set intViews = intSheet.Views
        Set intView = intViews.ActiveView
        Set intTexts = intView.Texts
        Set intNewText = intTexts.Add(CStr(intUserSelRange.Value), 0, 5)
        intNewText.Name = "ExcelImport"
    If Err.Number <> 0 Then
        MsgBox "Es ist ein Fehler beim Importvorang aufgetretten!" + vbNewLine + _
                "Stellen Sie sicher das eine View aktiviert ist in die sich ein Textfeld einfügen lässt!", vbExclamation, "Fehler"
        Exit Sub
    Else
        MsgBox "Der Importvorgang wurde erfolgreich abgeschlossen!" + vbNewLine + "Das neue Textfeld wurde in folgender Ansicht erzeugt und hat folgenden Inhalt:" + vbNewLine + _
                "Ansichtsname:" + vbTab + CStr(intView.Name) + vbNewLine + _
                "Textfeldinhalt:" + vbTab + CStr(intUserSelRange.Value), vbInformation, "Makro erfolgreich beendet"
    End If
        

End Sub


'***Funktion zum holen des CATIA Object
    Public Function GetCATIA() As Object
    
        '***Deklarationen
        Dim intCATIAObj As Object

        On Error Resume Next
        Set intCATIAObj = GetObject(, "CATIA.Application")
        If Err.Number <> 0 Then
            Err.Clear
            Set intCATIAObj = CreateObject("CATIA.Application")
        End If
        On Error GoTo 0
        If intCATIAObj Is Nothing Then
            Set GetCATIA = Nothing
        Else
            Set GetCATIA = intCATIAObj
        End If

    End Function


'***Function zum Selectieren der Excel Zelle
Private Function SelectCell() As Range

    '***Deklarationen
    Dim SelFailMsgBoxRes As VbMsgBoxResult
    Dim intUserSelRange As Range
    
    '***Selektion
    On Error Resume Next
    Set intUserSelRange = Application.InputBox("Bitte wählen Sie eine Zelle aus und klicken Sie " + Chr(34) + "OK" + Chr(34), "Koordinatenwerte selektieren", Type:=8)
    If Err.Number <> 0 Then
        Set SelectCell = Nothing
        On Error GoTo 0
        Exit Function
    Else
        On Error GoTo 0
    End If
        
    '***Auswertung
    If intUserSelRange Is Nothing Then
        Set SelectCell = Nothing
        Exit Function
    End If
    
    If intUserSelRange.Cells.Count <> 1 Then
        SelFailMsgBoxRes = MsgBox("Die Selektion ist ungültig da Sie mehr als eine Zelle selektiert haben !" + vbNewLine + _
                                  "Bitte selektieren Sie nur EINE Zelle" + vbNewLine + "Wollen Sie die Selektion wiederholen?", _
                                  vbExclamation + vbYesNo, "Ungültige Selektion")
        If SelFailMsgBoxRes = vbYes Then
            SelectCell
        Else
            Set SelectCell = Nothing
            Exit Function
        End If
    Else
        Set SelectCell = intUserSelRange
    End If


End Function
