Hallo Forum,
Wie im Beitrag weiter unten beschrieben, habe ich ein Makro geschrieben, dass die Baugruppenstückliste in eine Excel-Vorlage schreibt und dann sortiert. Nur das Sortieren macht einige Probleme: Es funktioniert nur beim ersten Start des Programms. Wenn ich es während einer Inventorsitzung ein zweites Mal starte, dann funktioniert der Sortieralgorithmus nicht mehr. Ich vermute ich beende Excel nicht korrekt:
Public Sub StuecklistenExport()
Dim XL As Object
Dim xlWB As Object
Dim xlWS As Object
'Baugruppenobjekt zuweisen
If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
MsgBox "Das aktive Dokument ist keine Baugruppe."
Exit Sub
End If
Dim oDoc As AssemblyDocument
Set oDoc = ThisApplication.ActiveDocument
'Excel öffnen, wenn nicht geöffnet
On Error Resume Next
Set XL = GetObject("Excel.Application")
If Err.Number Then
' Excel läuft noch nicht - starten
Err.Clear
On Error Resume Next
Set XL = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
Exit Sub
End If
End If
'Stüchlistenvorlage öffnen aus Verzeichnis 7-Inventordaten/Stückliste
'Pfad der Projektdatei suchen
Dim ProjektPfadtxt As String
ProjektPfadtxt = ThisApplication.FileLocations.FileLocationsFile
Dim Index As Long
Index = InStrRev(ProjektPfadtxt, "\")
ProjektPfadtxt = Left$(ProjektPfadtxt, Index)
'Stücklistenvorlage aus aktiven Projekt öffnen
On Error Resume Next
Set xlWB = XL.Workbooks.Open(ProjektPfadtxt + "7-Inventor-Daten\Stueckliste\Stueckliste_Vorl.xls")
If Err.Number Then
MsgBox "Kann Stücklistenvorlage nicht öffnen."
Exit Sub
End If
'Schriftfeld ausfüllen
xlWB.Sheets("Schriftfeld").Activate
Set xlWS = xlWB.ActiveSheet
Dim Benennung As String
Benennung = Property_lesen(oDoc, "Description")
xlWS.Application.Cells(27, 9).Value = Benennung
Dim Bauteilnummer As String
Bauteilnummer = Property_lesen(oDoc, "Part Number")
xlWS.Application.Cells(26, 9).Value = Bauteilnummer
Dim Auftragsnummer As String
Auftragsnummer = Property_lesen(oDoc, "Project")
xlWS.Application.Cells(30, 9).Value = Auftragsnummer
Dim Bearbeiter As String
Bearbeiter = ThisApplication.UserName
xlWS.Application.Cells(20, 9).Value = Bearbeiter
Dim Datum As Variant
Datum = Date
xlWS.Application.Cells(21, 9).Value = Datum
'Stückliste ausfüllen
xlWB.Sheets("Stückliste").Activate
Set xlWS = xlWB.ActiveSheet
Dim oBOM As BOM
Set oBOM = ThisApplication.ActiveDocument.ComponentDefinition.BOM
oBOM.StructuredViewFirstLevelOnly = True
oBOM.StructuredViewEnabled = True
Dim oRow As BOMRow
Dim oBOMView As BOMView
Set oBOMView = oBOM.BOMViews.Item("Strukturiert")
Dim Zeile As Long
Zeile = 3
Dim i As Long
For i = 1 To oBOMView.BOMRows.Count
' Get the current row.
Set oRow = oBOMView.BOMRows.Item(i)
Dim oCompDef As ComponentDefinition
Set oCompDef = oRow.ComponentDefinitions.Item(1)
Dim oPropSet As PropertySet
Set oPropSet = oCompDef.Document.PropertySets.Item("Design Tracking Properties")
'Zellen beschreiben
'Position
xlWS.Application.Cells(Zeile, 2).Value = oRow.ItemNumber
'Anzahl
xlWS.Application.Cells(Zeile, 3).Value = oRow.ItemQuantity
'Benennung
xlWS.Application.Cells(Zeile, 4).Value = oPropSet.Item("Description").Value
'Bauteilnummer
xlWS.Application.Cells(Zeile, 5).Value = oPropSet.Item("Part Number").Value
'Kürzel
xlWS.Application.Cells(Zeile, 6).Value = oPropSet.Item("Catalog Web Link ").Value
'Werkstoff
xlWS.Application.Cells(Zeile, 7).Value = oPropSet.Item("Material").Value
'Halbzeug
xlWS.Application.Cells(Zeile, 8).Value = oPropSet.Item("Revision Number ").Value
'Zulieferer
xlWS.Application.Cells(Zeile, 9).Value = oPropSet.Item("Vendor").Value
Zeile = Zeile + 1
Next
'Stückliste sortieren
Dim Anzahl_Zeilen As Long
Anzahl_Zeilen = oBOMView.BOMRows.Count
Dim Rangestr As String
Rangestr = "B3:I" & Format(Anzahl_Zeilen + 2)
xlWS.Range("B3:I73").Select
xlWS.Range("B3:I73").Sort Key1:=Range("B2")
'Wenn Lücken in Pos.-Nr.-Folge, dann Leerzeile einfügen
Dim Inhalt_Pos As Integer
Dim Inhalt_Pos_1 As Integer
Zeile = 3
Inhalt_Pos_1 = 0
Do
Inhalt_Pos = xlWS.Application.Cells(Zeile, 2).Value
If (Inhalt_Pos_1 + 1) < Inhalt_Pos Then
xlWS.Application.Cells(Zeile, 2).Select
xlWS.Application.Selection.EntireRow.Insert
End If
Inhalt_Pos_1 = Inhalt_Pos
Zeile = Zeile + 1
Loop While Inhalt_Pos <> 0
'Druckbereich festlegen
xlWB.Sheets("Stückliste formatiert").Activate
Set xlWS = xlWB.ActiveSheet
Dim Blattanzahl As Integer
Blattanzahl = xlWS.Cells(39, 13).Value
Dim Druckzeilen As String
Druckzeilen = Format(Blattanzahl * 40)
xlWS.PageSetup.PrintArea = "$A$1:$M$" + Druckzeilen
'Speichern
Dim Stueli_Name As String
Dateiname = Left$(ThisApplication.ActiveDocument.FullFileName, Len(ThisApplication.ActiveDocument.FullFileName) - 4) + ".xls"
xlWB.SaveAs Dateiname
'Baugruppenanzahl abfragen
MsgBox "Bitte Baugruppenanzahl ausfüllen!"
xlWB.Sheets("Schriftfeld").Activate
Set xlWS = xlWB.ActiveSheet
XL.Visible = True
'Excel schließen
'XL.Application.Quit
'Verbindung zu Excel lösen
Set xlWS = Nothing
Set xlWB = Nothing
Set XL = Nothing
End Sub
Kann mir jemand helfen?
MfG Frank
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
