Code:
Sub StuLi_KD1_DE_EN()
Dim oapp As Inventor.ApplicationSet oapp = ThisApplication
Dim oDoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set oDoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim i As Property
Dim POS As String
Set oProp = oDoc.PropertySets.Item("Design Tracking Properties")
For Each i In oProp
If i.DisplayName = "Bezeichnung" Then
oDESCRIPTION = i.Expression
ElseIf i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
End If
Next
oFileName = oPartNumber & "." & oDESCRIPTION
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oXLSFileName = oFileName & ".xls"
'oName = Name des Excel- Sheets
oName = "test"
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "U:\Vorlagen_INV2013\Stueli\BMW Makro\template2.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = True
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If oDoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf oDoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!" _
, vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If
Call oDoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
End If
End If
oExl.Workbooks.Open (oXLSFileName)
With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oDESCRIPTION
.Close 1
End With
End Sub