'---------------------------------------------------------------------------------
'(c) Lothar Boekels 2007
'    Boekels Ingenieurbüro für Maschinenbau
'    Schroerskamp 74
'    41069 Mönchengladbach
'    kontakt@boekels-online.de
'---------------------------------------------------------------------------------



Option Explicit


'--------------------------------------------------------------------------------------------------




Public Sub exportToExcel()

    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And _
        ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        MsgBox "Only Part or Assymbly document", vbCritical
        Exit Sub
    End If
    
    
    Dim oParams As Parameters
    Dim sDocName As String
    Dim i As Long
    Dim iRow As Long

    Dim XL As Object
    Dim ExcelLiefNicht As Boolean    ' Attribut für Freigabe am Ende.

    Dim xlWB As Object
    Dim xlWS As Object

    ' Überprüfen, ob eine Kopie von Microsoft Excel bereits
    ' ausgeführt wird.
    On Error Resume Next    ' Fehlerbehandlung zurückstellen.
    ' GetObject-Funktionsaufruf ohne erstes Argument gibt einen Verweis auf
    ' eine Instanz der Anwendung zurück. Wenn die Anwendung nicht
    ' ausgeführt wird, tritt ein Fehler auf.
    
    Set XL = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        ExcelLiefNicht = True
        Set XL = CreateObject("Excel.Application")
    End If
    Err.Clear    ' Err-Objekt im Fehlerfall löschen.

    ' Prüfen auf Microsoft Excel. Wenn Microsoft Excel ausgeführt wird, wird
    ' dies in die Tabelle ausgeführter Objekte eingetragen.
    'DetectExcel
    
    Set oParams = ThisApplication.ActiveDocument.ComponentDefinition.Parameters
    ThisApplication.Visible = True

    On Error GoTo 0
    
    Set xlWB = XL.Workbooks.Add
    Set xlWS = xlWB.ActiveSheet
    XL.Visible = False
    
    
    '
    ' iRow = 1
    ' xlWS.Cells(iRow, 1).Value = "Type"
    ' XlWS.Cells(iRow, 2).Value = "Name"
    ' xlWS.Cells(iRow, 3).Value = "Unit"
    ' xlWS.Cells(iRow, 4).Value = "Expression"
    ' xlWS.Cells(iRow, 5).Value = "Value"
    ' xlWS.Cells(iRow, 6).Value = "Export"
    ' xlWS.Cells(iRow, 7).Value = "Health"
    ' xlWS.Cells(iRow, 8).Value = "Comment"

    Dim iColumnType As Integer
    Dim iColumnName As Integer
    Dim iColumnUnit As Integer
    Dim iColumnExpression As Integer
    Dim iColumnValue As Integer
    Dim iColumnExport As Integer
    Dim iColumnHealth As Integer
    Dim iColumnComment As Integer
    
    iColumnType = 1
    iColumnName = 2
    iColumnUnit = 3
    iColumnExpression = 4
    iColumnValue = 5
    iColumnExport = 6
    iColumnHealth = 7
    iColumnComment = 8
    

    
    
    'Write the Header Row
    iRow = 1
    xlWS.Cells(iRow, iColumnType).Value = "Type"
    xlWS.Cells(iRow, iColumnName).Value = "Name"
    xlWS.Cells(iRow, iColumnUnit).Value = "Unit"
    xlWS.Cells(iRow, iColumnExpression).Value = "Expression"
    xlWS.Cells(iRow, iColumnValue).Value = "Value"
    xlWS.Cells(iRow, iColumnExport).Value = "Export"
    xlWS.Cells(iRow, iColumnHealth).Value = "Health"
    xlWS.Cells(iRow, iColumnComment).Value = "Comment"

    'Some Excel formatting:
    xlWS.Rows("2:2").Select
    XL.ActiveWindow.FreezePanes = True
    
    xlWS.Rows("1:1").Select
    XL.Selection.Font.Bold = True
    With XL.Selection.Font
        .name = "Arial"
        .Size = 14
        .Bold = True
    End With

    xlWS.Columns("A:H").Select
    XL.Selection.AutoFilter

    Dim sParameterType As String
    Dim sHealthStatus As String
    Dim dModelValue As Double
    
    For i = 1 To oParams.Count
        iRow = iRow + 1
        
        ThisApplication.StatusBarText = "Parameter " & CStr(i) & " von " & CStr(oParams.Count)
       
        
        Select Case oParams.Item(i).Type
            Case kModelParameterObject
                sParameterType = "Model"
            Case kUserParameterObject
                sParameterType = "User"
            Case kTableParameterObject
                sParameterType = "Table"
            Case Else
                sParameterType = "Ref"
        End Select
        
        Select Case oParams.Item(i).HealthStatus
            Case kDeletedHealth
                sHealthStatus = "Deleted"
            Case kDriverLostHealth
                sHealthStatus = "Driver Lost"
            Case kInErrorHealth
                sHealthStatus = "In Error"
            Case kOutOfDateHealth
                sHealthStatus = "Out of Date"
            Case kUnknownHealth
                sHealthStatus = "Unknown"
            Case kUpToDateHealth
                sHealthStatus = "Up to Date"
        End Select
        
        Select Case oParams.Item(i).Units
            Case "mm"
                dModelValue = CDbl(oParams.Item(i).ModelValue) * 10
            Case Else
                dModelValue = CDbl(oParams.Item(i).ModelValue)
        End Select
        
       
        xlWS.Cells(iRow, iColumnType).Value = sParameterType
        xlWS.Cells(iRow, iColumnName).Value = oParams.Item(i).name
        xlWS.Cells(iRow, iColumnUnit).Value = oParams.Item(i).Units
        xlWS.Cells(iRow, iColumnExpression).Value = oParams.Item(i).Expression
        xlWS.Cells(iRow, iColumnValue).Value = dModelValue
        xlWS.Cells(iRow, iColumnExport).Value = oParams.Item(i).ExposedAsProperty
        xlWS.Cells(iRow, iColumnHealth).Value = sHealthStatus
        xlWS.Cells(iRow, iColumnComment).Value = oParams.Item(i).Comment
        
    Next
    
    XL.Visible = True
    
    'Format the entire page so cell contents fit
    xlWS.Cells.Select
    xlWS.Cells.EntireColumn.AutoFit
    
    ' Sort
    xlWS.Columns("A:H").Select
    
    XL.Selection.Sort _
            Key1:=Range("A2"), _
            Order1:=xlAscending, _
            Key2:=Range("B2"), _
            Order2:=xlDescending, _
            Header:=xlGuess, _
            OrderCustom:=1, _
            MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal, _
            DataOption2:=xlSortNormal

    xlWS.Range("A1").Select
    
    
    'save this XL document, default to Inventor location and name
    sDocName = ThisApplication.ActiveDocument.FullFileName
    If sDocName = "" Then
        sDocName = "c:\temp\x"
    Else
        sDocName = Mid(sDocName, 1, Len(sDocName) - 4)
    End If
    If Dir(sDocName & ".xls") <> "" Then
        i = 1
        Do While Dir(sDocName & "_" & i & ".xls") <> ""
            i = i + 1
        Loop
        sDocName = sDocName & "_" & i
    End If
    
    XL.Visible = False
    
        Dim oFileDlg As FileDialog
        Call ThisApplication.CreateFileDialog(oFileDlg)

        ' Define the filter to select the ini-file or any file.
         oFileDlg.Filter = "Excel Files (*.xls)|*.xls|All Files (*.*)|*.*"

        ' Define the files filter to be the default filter.
        oFileDlg.FilterIndex = 1

        ' Set the title for the dialog.
        oFileDlg.DialogTitle = "Specify Output File"

        ' Set the initial directory that will be displayed in the dialog.
        oFileDlg.InitialDirectory = ThisApplication.ActiveDocument.FullFileName

        ' Set the flag so an error will be raised if the user clicks the Cancel button.
        oFileDlg.CancelError = False
        
        oFileDlg.FileName = sDocName

        ' Show the open dialog. The same procedure is also used for the Save dialog.
        ' The commented code can be used for the Save dialog.
        On Error Resume Next

        oFileDlg.ShowSave
        ' oFileDlg.ShowSave

        ' If an error was raised, the user clicked cancel, otherwise display the filename.
        If Err Then
            'MsgBox "User cancelled out of dialog" & vbCrLf & vbCrLf & "Exiting Makro"
        ElseIf oFileDlg.FileName = "" Then
            'MsgBox "No Filename was specified" & vbCrLf & vbCrLf & "Exiting Makro"
        Else
            xlWB.SaveAs FileName:=oFileDlg.FileName
            xlWS.Close
        End If
        
    XL.Visible = True
    
    ' Wenn diese Kopie von Microsoft Excel beim Starten des Beispiels
    ' nicht ausgeführt wurde, wird Excel mit der Quit-Methode des
    ' Application-Objekts beendet. Wenn Sie versuchen, Microsoft Excel zu
    ' beenden, blinkt die Titelleiste, und Sie werden
    ' in einer Meldung gefragt, ob Sie geladene Dateien speichern möchten.
    If ExcelLiefNicht = True Then
        XL.Application.Quit
    End If

    Set XL = Nothing    ' Verweis auf Anwendung und Tabelle freigeben.

    Set xlWS = Nothing
    Set xlWB = Nothing
     

End Sub

     

'--------------------------------------------------------------------------------------------------





Public Sub importFromExcel()

' Import Excel parameter expressions in Inventor for existing parameters only
' Limitation: Currently NO new Parameters will be created in Inventor
' Note: Excel layout MUST match the one created by "importFromExcel"
    
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And _
        ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        MsgBox "Only Part or Assymbly document", vbCritical
        Exit Sub
    End If
    
    

    ' 1. Zeile: Überschriften
    ' in jeder weiteren Zeile ein Parameter,
    ' Leerzeilen werden als Ende der Paramterliste interpretiert.

    '
    ' iRow = 1
    ' xlWS.Cells(iRow, 1).Value = "Type"
    ' XlWS.Cells(iRow, 2).Value = "Name"
    ' xlWS.Cells(iRow, 3).Value = "Unit"
    ' xlWS.Cells(iRow, 4).Value = "Expression"
    ' xlWS.Cells(iRow, 5).Value = "Value"
    ' xlWS.Cells(iRow, 6).Value = "Export"
    ' xlWS.Cells(iRow, 7).Value = "Health"
    ' xlWS.Cells(iRow, 8).Value = "Comment"

    Dim iColumnType As Integer
    Dim iColumnName As Integer
    Dim iColumnUnit As Integer
    Dim iColumnExpression As Integer
    Dim iColumnValue As Integer
    Dim iColumnExport As Integer
    Dim iColumnHealth As Integer
    Dim iColumnComment As Integer
    
    iColumnType = 1
    iColumnName = 2
    iColumnUnit = 3
    iColumnExpression = 4
    iColumnValue = 5
    iColumnExport = 6
    iColumnHealth = 7
    iColumnComment = 8
    
    
    Dim oParams As Parameters
    Dim sDocName As String
    Dim i As Long
    Dim iRow As Long
    Dim XL As Object
    Dim xlWS As Object
    
    Set oParams = ThisApplication.ActiveDocument.ComponentDefinition.Parameters
    
    
    'Open existing Excel Workbook
    sDocName = ThisApplication.ActiveDocument.FullFileName
    If sDocName = "" Then
        sDocName = "c:\temp\Test.xls"
    Else
        sDocName = Mid(sDocName, 1, Len(sDocName) - 4) & ".xls"
    End If
    
    Set XL = GetObject(sDocName)
    
    If XL Is Nothing Then
        MsgBox "Failed to open '" & sDocName & "'", vbCritical
        Exit Sub
    End If
    
    Set xlWS = XL.ActiveSheet
    'Debug.Print sDocName
    
        
    ' Übertrag in die Paramter des InventorModells
    Dim bNurUpdate As Boolean
    bNurUpdate = False
    
    If bNurUpdate Then
        
        ' Collect the Model and User variable-names
        ' Remember them in a collection, i.e. indexed and variable length array.
        ' No sorting and searching required
        
        Dim colXLparams As New Collection
        iRow = 2    'skip header row
        
        Do While xlWS.Cells(iRow, iColumnType).Value <> ""
            If InStr("MODEL|USER", UCase(xlWS.Cells(iRow, iColumnType).Value)) Then
                
                ' nur für User und Modell Parameter
                colXLparams.Add iRow, xlWS.Cells(iRow, iColumnName).Value
                
            End If
            iRow = iRow + 1
        Loop
        
        
        ' Update der vorhandenen Parameter des Inventor-Modells
        ' mit den -> Werten <- der Collection aus der Excel-Datei.

        
        On Error Resume Next    'in case oParams.Item(i).name is NOT in Excel
        
        For i = 1 To oParams.Count
            Select Case oParams.Item(i).Type
                Case kModelParameterObject, kUserParameterObject
                
                    iRow = colXLparams(oParams.Item(i).name)
                    oParams.Item(i).Expression = xlWS.Cells(iRow, iColumnExpression).Value
                
                Case Else
            End Select
        Next
        
    Else
    
        ' Übertrag in die Paramter des InventorModells
        ' dabei werden alle Parameter aus der Excel-Liste durchlaufen und jeweils mit den
        ' vorhandenen Parameter des Inventor-Modells verglichen.
        '
        ' Bei Übereinstimmung der Namen werden die Inhalte:
        ' - Name (ist eh gleich)
        ' - Formel
        ' - Einheit
        '
        ' durchgelaufen und die Daten entsprechend der Collection gesetzt.
        ' Sollten die Parameter nicht gefunden werden, so werden die Paramter neu erstellt.
        ' Hierbei sollte die Reihenfolge in der Excel-Tabelle so gewählt werden, dass dies auch
        ' logischerweise funktionieren kann.


        Dim bParameterFound As Boolean
        bParameterFound = False
        
        Dim sParamName As String
        sParamName = ""
        Dim sParamExpression As String
        sParamExpression = ""
        Dim sParamUnit As String
        sParamUnit = ""
        Dim bParamExport As Boolean
        bParamExport = False
        Dim sParamComment As String
        sParamComment = ""
        
        iRow = 2    'skip header row
        
        Do While xlWS.Cells(iRow, iColumnType).Value <> ""      ' erste Spalte muss ausgefüllt sein!
            If InStr("MODEL|USER|TABLE", UCase(xlWS.Cells(iRow, iColumnType).Value)) Then
                
                sParamName = xlWS.Cells(iRow, iColumnName).Value
                sParamExpression = xlWS.Cells(iRow, iColumnExpression).Value
                sParamUnit = xlWS.Cells(iRow, iColumnUnit).Value
                If InStr("RICHTIG|TRUE|WAHR|EXPORT", UCase(xlWS.Cells(iRow, iColumnExport).Value)) Then bParamExport = True
                sParamComment = xlWS.Cells(iRow, iColumnComment).Value

                For i = 1 To oParams.Count
                    If oParams.Item(i).name = sParamName Then
                        bParameterFound = True
                    End If
                Next i
            
                If Not bParameterFound Then
                    Call oParams.UserParameters.AddByExpression(sParamName, sParamExpression, sParamUnit)
                Else
                    oParams(sParamName).Expression = sParamExpression
                    oParams(sParamName).Units = sParamUnit
                End If
                    
                oParams(sParamName).ExposedAsProperty = bParamExport
                oParams(sParamName).Comment = sParamComment
                    

                'Debug.Print sParamName & " - nachher "
                'Debug.Print vbTab & "Expression : " & CStr(oParams(sParamName).Expression)
                'Debug.Print vbTab & "Unit       : " & CStr(oParams(sParamName).Units)
                'Debug.Print vbTab & "Value      : " & CStr(oParams(sParamName).Value)
                'Debug.Print vbTab & "Comment    : " & CStr(oParams(sParamName).Comment)
                'Debug.Print

                
            End If
            
            iRow = iRow + 1
            ThisApplication.ActiveDocument.Update

        Loop

        
        
    
    End If

    
    
    
    ThisApplication.ActiveDocument.Update
    
    'detach from XL
    Set xlWS = Nothing
    Set XL = Nothing
     

End Sub

 
'--------------------------------------------------------------------------------------------------



Sub dummy()

End Sub