Hallo Zusammen,
ich habe in den letzten Tage einige Beträge durchgearbeit auf der Suche nach einem Macro für den Automatisierten Export einer Stückliste in eine Excel-Vorlage.
Bin soweit auch fündig geworden und konnte den Großteil meiner Bedürfnisse anpassen und es für mich Übersichtlich machen. Das hat soweit auch gut geklappt bis auf das Eintragen von "Benutzerdefinierten iPropertys" und einem flexibelen AblagePfad der beim Exportieren (über dropdown Menü) ausgewählt werden kann. Ich habe einiges ausprobiert und bin leider zu keinem Ergebniss gekommen.
hier mein aktueller Code mit meinem letzten kläglichen Versuch.
______________________________________________________________________________________________________________________________________________________________________
Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Makro 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 oProp As PropertySet
Dim i As Property
Dim oDescription As String
Dim oPartNumber 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
'_____________________________________________________________________________________________________
'Dim k As CustomProperty
'Dim oKonstName As String
'Dim oKonstDatum As String
'Dim oGezDatum As String
'Dim oGezName As String
'Dim oTitel2 As String
'Set oProp = odoc.CustomPropertyFormat.Item("Design Tracking Properties")
'For Each k In oProp
' If k.DisplayName = "KonstName" Then
' oKonstName = k.Expression
' ElseIf k.DisplayName = "KonstDatum" Then
' oKonstDatum = k.Expression
' ElseIf k.DisplayName = "GezDatum" Then
' oGezDatum = k.Expression
' ElseIf k.DisplayName = "GezName" Then
' oGezName = k.Expression
' ElseIf k.DisplayName = "Titel2" Then
' oTitel2 = k.Expression
' End If
' Next
'_____________________________________________________________________________________________________
oFileName = "Stüli" & " - " & oPartNumber
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oXLSFileName = "E:\test\" & oFileName & ".xls"
'oName = Name des Excel- Sheets bzw. Baugruppe
oName = oDescription
'oStart = Start- Zelle
oStart = "A9"
'oTemplate = Pfad zum xls- Template
oTemplate = "J:\Stüli-Vorlage.xls"
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
'_________________________________________________________________________________________________________
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(4, 1) = oPartNumber
'.Sheets(oName).Cells(4, 4) = oKonstDatum
'.Sheets(oName).Cells(4, 3) = oKonstName
'.Sheets(oName).Cells(6, 4) = oGezDatum
'.Sheets(oName).Cells(6, 3) = oGezName
'.Sheets(oName).Cells(2, 3) = oTitel2
.Close 1
End With
End Sub
__________________________________________________________________________________________________________________________________________________
Da ich leider so gut wie keine Ahnung von VBA Programmierung habe hoffe ich das mir hier jemand Helfen kann meine Probleme zu Lösen.
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP