VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsPartListToFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Implements ApplicationAddInServer

Private oInventorApp As Inventor.Application

Private i As Long
Private pfad As String
Private dateiName As String
Private dateiNameNeu As String
Private dateiName2() As String
Private oDrawDoc As DrawingDocument
Private oPartList As PartsList
Private count As Long

Private WithEvents objAppEvents As ApplicationEvents
Attribute objAppEvents.VB_VarHelpID = -1

Private Sub ApplicationAddInServer_Activate(ByVal AddInSiteObject As Inventor.ApplicationAddInSite, ByVal FirstTime As Boolean)

    ' Save a reference to the Application object.
    Set oInventorApp = AddInSiteObject.Application
    Set objAppEvents = oInventorApp.ApplicationEvents
    
End Sub

Private Property Get ApplicationAddInServer_Automation() As Object

    Set ApplicationAddInServer_Automation = Nothing
    
End Property

Private Sub ApplicationAddInServer_Deactivate()

    Set oInventorApp = Nothing
    
End Sub

Private Sub ApplicationAddInServer_ExecuteCommand(ByVal CommandID As Long)

    ' No longer used.
    
End Sub

Private Sub objAppEvents_OnCloseDocument(ByVal DocumentObject As Document, ByVal FullFileName As String, ByVal BeforeOrAfter As EventTimingEnum, ByVal Context As NameValueMap, HandlingCode As HandlingCodeEnum)
  
  If FullFileName = "" Then Exit Sub
  
  If BeforeOrAfter = kBefore Then
    
        pfad = Replace(FullFileName, Split(FullFileName, "\")(UBound(Split(FullFileName, "\"))), "")
        dateiName = Replace(FullFileName, pfad, "")
        dateiName2 = Split(dateiName, ".")
            
        If Len(dateiName2(UBound(dateiName2))) Then
          count = UBound(dateiName2)
        Else
          count = UBound(dateiName2) - 1
        End If
                
        If dateiName2(count) = "idw" Then
        
            For i = 1 To DocumentObject.Sheets.count
                
                If DocumentObject.Sheets(i).PartsLists.count > 0 Then
          
                     Set oPartList = DocumentObject.Sheets(i).PartsLists.Item(1)
                     
                     ' Prüfen, ob die Excel-Stückliste geöffnet ist
                     Dim fehler As Boolean
                     Dim objFso As Object
                     Set objFso = CreateObject("Scripting.FileSystemObject")
                     Dim fileIsClosed As Boolean
                     Dim counterCol As Long
                     
                     dateiNameNeu = dateiName2(0)
                     For counterCol = 1 To (count - 1)
                        dateiNameNeu = dateiNameNeu + "." + dateiName2(counterCol)
                     Next

                     If objFso.FileExists(pfad + dateiNameNeu + " Stückliste.xls") Then
                        If IsFileOpen(pfad + dateiNameNeu + " Stückliste.xls") Then
                            fehler = MsgBox("Stückliste konnte nicht erstellt werden, da die Excel-Datei geöffnet ist.", vbCritical, "Fehler beim Speichern")
                            Exit Sub
                        Else
                            fileIsClosed = True
                        End If
                     End If

                    
                    'Frage, ob die Stückliste gespeichert werden soll
                    If MsgBox("Wollen Sie die Stückliste speichern?", vbYesNo, "Stückliste Speichern?") = vbYes Then
                
                        'Excel-Variablen deklarieren
                        Dim oExcelApp As Excel.Application
                        Dim oExcelWbk As Excel.Workbook
                        Dim oExcelWks As Excel.WorkSheet
                        Dim oExcelRange As Excel.Range
                
                        'alte Excel-Datei löschen
                        If fileIsClosed Then
                            Kill (pfad + dateiNameNeu + " Stückliste.xls")
                        End If
                        
                        'Excel-Datei erstellen
                        On Error Resume Next
                          Set oExcelApp = CreateObject("Excel.Application")
                          Set oExcelWbk = oExcelApp.Workbooks.Add
                          If Err.Number Then
                             Err.Clear
                             MsgBox "Excel kann nicht erstellt werden", vbExclamation, "Excel-Fehler"
                          End If
          
                        'Excel bearbeiten
                        Set oExcelWks = oExcelWbk.ActiveSheet
             
                        'Spalten A bis Z als Text kennzeichnen
                        oExcelApp.Columns("A:Z").EntireColumn.NumberFormat = "@"

                        'Excel mit Daten füllen
                        'Kopfzeile
                        Dim counterColumn As Long
                        For counterColumn = 1 To oPartList.PartsListColumns.count
                            oExcelWks.Cells(1, counterColumn) = oPartList.PartsListColumns.Item(counterColumn).Title
                            oExcelWks.Cells(1, counterColumn).Font.Bold = True
                        Next
     
                        'Datenzeilen
                        Dim maxRows As Long
                        maxRows = oPartList.PartsListRows.count
                        
			'Stücklisten Artikel nach Excel exportieren
                        WritePartList 1, maxRows, counterColumn, oExcelWks
                         
                        
                        'Spalten A bis Z optimale Breite
                        oExcelApp.Columns("A:Z").EntireColumn.AutoFit
                        oExcelApp.Columns("A:Z").EntireColumn.HorizontalAlignment = xlLeft
    
                        'Spalten A bis G mit Rahmen
                        oExcelApp.Columns("A:G").EntireColumn.Borders.LineStyle = xlContinuous
       
                        'Seitenformat einstellen
                        oExcelWks.PageSetup.Orientation = xlLandscape
                        oExcelWks.PageSetup.CenterHeader = "Stückliste: " + dateiNameNeu
                        oExcelWks.PageSetup.LeftFooter = "erstellt am: " + CStr(Date)
                        oExcelWks.PageSetup.RightFooter = "Seite &P von &N"
                        oExcelWks.PageSetup.PrintTitleRows = "$1:$1"
                        oExcelWks.PageSetup.Zoom = False
                        oExcelWks.PageSetup.FitToPagesWide = 1
                        oExcelWks.PageSetup.FitToPagesTall = 100
                   
                        'Excel schließen
                        oExcelRange.Clear
                        oExcelWbk.SaveAs (pfad + dateiNameNeu + " Stückliste.xls")
                        oExcelWbk.Close True
                        oExcelApp.Quit
                        Set oExcelRange = Nothing
                        Set oExcelWks = Nothing
                        Set oExcelWbk = Nothing
                        Set oExcelApp = Nothing
                        
                    Else
                        fehler = MsgBox("Stückliste wurde nicht gespeichert!", vbCritical, "Fehler beim Speichern")
                        
                    End If
          
                End If
                
            Next
        
        End If
    
  End If
    
End Sub

Public Function WritePartList(counterRowOld As Long, maxRows As Long, counterColumn As Long, oExcelWks As Excel.WorkSheet)
    Dim counterRow As Long

    For counterRow = counterRowOld To maxRows
        Dim oRow As PartsListRow
        Set oRow = oPartList.PartsListRows.Item(counterRow)
        
        For counterColumn = 1 To oPartList.PartsListColumns.count
            Dim oCell As PartsListCell
            Set oCell = oRow.Item(counterColumn)
            oExcelWks.Cells(counterRow + 1, counterColumn) = "" + CStr(oCell.Value)
        Next
        
        'Stückliste auflösen
        If oRow.Expandable Then
            oRow.Expanded = True
            WritePartList counterRow + 1, oPartList.PartsListRows.count, counterColumn, oExcelWks
        End If
    Next

End Function

Public Function IsFileOpen(ByRef Path As String) As Boolean
  Dim FileNr As Integer
  Dim ErrorNr As Long

  'Datei testweise öffnen:
  On Error Resume Next
    FileNr = FreeFile
    Open Path For Input Lock Write As #FileNr
      ErrorNr = Err.Number
    Close #FileNr
  On Error GoTo 0

  'Ggf. Fehler verarbeiten:
  Select Case ErrorNr
  Case 0    'kein Fehler:
    'NOP
  Case 70   'Permission denied':
    IsFileOpen = True
  Case Else 'sonstiger Fehler:
    Err.Raise ErrorNr
  End Select
End Function