---

Hallo
Nachdem Gestern das mit der Schreibweise in einer Excel Tabelle so gut geklappt hat nun zum nächsten Problem.
Es geht noch immer um die Brennschnittteile in einer Baugruppe.

Ich greife mit einer Schleife „For Each oRefDoc In oRefDocs“ auf alle Teile/Unterbaugruppen innerhalb meiner Hauptbaugruppe zu.
Danach filtere ich die Brennschnittzeichnungen heraus und schreibe eine Zeile mit Teilenummer, … in eine Excel Tabelle.
Das funktioniert auch schon sehr gut.
Jetzt möchte ich aber noch eine Sortierung in meiner Excel Tabelle.
Und zwar so,  dass alle Teile die zu einer Unterbaugruppe gehören auch untereinander stehen.

100 Hauptbaugruppe
101 Teil 1
102 Teil 2
103 Teil 3
u.s.w. ...
200 Unterbaugruppe 1
201 Teil 1
202 Teil 2
203 Teil 3
u.s.w. ...

So, mein Frage ist nun:
Wie kann ich die Baugruppe herausfinden in der das Bauteil enthalten ist?
- „oRefDoc.Parent „ liefert immer den gleichen Wert, was nicht sein kann!
- kann das mit der Schleife „For Each oRefDoc In oRefDocs“ überhaupt  funktionieren
- oder muss ich über die Stückliste gehen?

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Es ist schon richtig das oRefedDoc.Parent immer den gleichen Wert liefert. Die AllReferencedDocuments sind eine flache Liste aller Dokumente. Keine Anzahl und keine Baugruppenstruktur.
Wenn du wissen willst, was wo verbaut ist solltest du über die Stückliste gehen. Schau dir dazu mal den Thread an.
Die ausgelesenen Teile solltest du in ein 2-dimensionales Array (Parentbaugruppe und Teilename) schreiben. Das läßt sich wenn ich nicht irre passend sortieren. Das komplette Array kannst du dann in einem Rutsch in die Exceltabelle schreiben. Schau dazu mal in diesen Beitrag unter dem Kapitel "Verwendung der Automatisierung zum Übertragen eines Arrays mit Daten auf einen Bereich in einem Arbeitsblatt".

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Ja, ich hab‘s befürchtet dass es so ist wie du gesagt hast.
Mit der „For Each oRefDoc …“ komme ich da nicht weiter.
Also, ich werd’s dann mal mit „...oBOMRow ...“ versuchen.
Danke

mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Ich will nun mein Exportmakro für die Brennschnittteile umstellen, sodass  auf die Stückliste zugegriffen wird .
Der erste Schritt dazu, das Auslesen der benötigten iProperty‘s klapp auch schon ganz gut.

Mir fehlt aber noch der Speicherort der einzelnen Teile. Ich möchte ja anschließend alle Zeichnungen öffnen und die Schnittzeichnung als .dxf exportieren.
Mit der folgenden Zeile komme ich an die Teilenummer ran:
oBomR.ComponentDefinitions(1).Document.PropertySets(3).Item("Part Number").Value
Wie lautet denn das Schlüsselwort für den Speicherort? (hab's nicht gefunden)

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

In der Stücklistenzeile über ReferencedFileDescriptor.FullFileName oder über ComponentDefinitions(1).Document.FullDocumentName kommst du an das referenzierte Dokument und kannst dann den String mit dem Pfad zum Bauteil z.B. mit

Code:

---

Dim sPfad As String
sPfad= Left(oBomRow.ReferencedFileDescriptor.FullFileName, Len(oBomRow.ReferencedFileDescriptor.FullFileName)-4) & ".idw"

---

in den Pfad zur gleichnamigen IDW im gleichen Pfad ändern.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf
So, nun bin ich wieder ein paar Schritte weiter gekommen.
Ich habe nun zweie Array’s mit allen benötigten Daten für Brennschnitte und für Laserschnitte.
Weiter‘s habe ich eine sortierte (!) Array mit den Baugruppennummern die diese Brenn. – oder Laserschnitte enthalten.
Für diese Baugruppen brauche ich jetzt aber noch die Benennung.

Zur Baugruppennummer komme ich einfach über „sCol(1) = Parent“
Die Benennung der Baugruppe steht in“ ????? ("Title").Value“
Meine Frage ist nun wie ich zu dieser Benennung komme?

Wäre toll wenn du mir wieder weiterhelfen könntest.
Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Was ist bei dir die "Benennung"? Meinst du das iPropertie "Title" bzw. "Titel"? Das wäre, ausgehend von der Stücklistenzeile der Baugruppe

Code:

---

oBOMRow.ComponentDefinitions.Item(1).Parent.PropertySets.Item(1).Item(1).Value

---

Das setzt voraus, das die Zusammenführung von Zeilen bei gleicher Bauteilnummer deaktiviert ist. Sonst gibt es unter Umständen in ComponentDefinitions mehr als nur 1 Item und somit mehrere Titel. Das sollte hier aber nicht der Fall sein.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Ich bin ein paar Tage beruflich verhindert gewesen, aber jetzt geht‘s weiter.

Ich hab jetzt schon fast alle Daten beisammen die ich in die Excel Tabelle schreiben möchte.
Es gibt da noch ein benutzerdefiniertes iProperty in der .idw auf das ich noch zugreifen möchte.
Dazu möchte ich aber die Zeichnung nicht öffnen müssen!
Ich hab ja eine Baugruppe geöffnet wenn ich das Makro ausführe.
Das Teil zu der die Zeichnung gehört ist in der geöffneten Baugruppe enthalten.
Meine Frage ist nun wie ich auf das iProperty „Zusatztext“ in der .idw zugreifen kann?

Wäre toll wenn‘s dafür auch eine Lösung gäbe.
Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi

Tja, wie kommt man an die Bonbons im Glas ohne es zu öffnen? Mir ist keine Möglichkeit bekannt.  

Aber man könnte den ApprenticeServer nehmen, der die Zeichnung deutlich schneller öffnet.

Code:

---

Private Sub iPropFromIDW()

Dim oApp As Application
Set oApp = ThisApplication

Dim oDoc As Document
Set oDoc = oApp.ActiveDocument

Dim sFile As String
sFile = Left(oDoc.FullDocumentName, Len(oDoc.FullDocumentName) - 3) & "idw"

Dim oAppr As New ApprenticeServerComponent

Dim oApprDoc As ApprenticeServerDrawingDocument
Set oApprDoc = oAppr.Open(sFile)

Dim oProp As Property
For Each oProp In oApprDoc.PropertySets.Item("inventor user defined properties")
    If oProp.Name = "Zusatztext" Then
        MsgBox oProp.Value
    End If
Next

Call oApprDoc.Close

Set oAppr = Nothing
End Sub

---

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Ja, das Funktioniert schon ganz gut.
Allerdings habe ich jetzt ein Problem mit der Stückzahl der Einzelteile.
In verschiedenen Unterbaugruppen wird das gleiche Teil eingebaut.
Da ich für Jedes Teil schon die Gesamtstückzahl zugewiesen habe stimmt nun die Excel Tabelle nicht mehr.
Dort habe ich nun das Bauteil mehrfach mit der Gesamtstückzahl stehen.

In deiner vorletzten Antwort hast du geschrieben:
„Das setzt voraus, das die Zusammenführung von Zeilen bei gleicher Bauteilnummer deaktiviert ist.“
Wie kann ich das aktivieren?

Meine Stückliste habe ich folgender Maßen eingesellt:
    oBOM.StructuredViewFirstLevelOnly = False
    oBOM.StructuredViewEnabled = True
    Set oStructuredBOMView = oBOM.BOMViews.Item("Strukturiert")

mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Was meinst du mit "die Gesamtstückzahl zugewiesen"? Da kann ich dir gedanklich leider nicht folgen.

Die Bauteilnummernzusammenführung fasst verschiedene Bauteile zu einer Stücklistenzeile zusammen, wenn im iProp Bauteilnummer das gleiche drin steht. Damit könnte man z.B. verschiedene lange Rohrstücken zu einer Gesamtmenge zusammenfassen lassen. Meines Wissens führt Inventor aber nur innerhalb einer Baugruppe zusammen, nicht über mehrere Stücklistenebenen.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Ja, die Formulierung "die Gesamtstückzahl zugewiesen" ist etwas unglücklich.
Ich meine damit das ich für jedes Bauteil die Gesamtanzahl der Exemplare in der Baugruppe (inkl. aller unterbaugruppen) als Stückzahl ins Array geschrieben haben.
Du hast mir bei der Funktion zur Gesamtstückzahl auch schon geholfen.

Das Problem mit den gleichen Teilen die in verschiedenen Unterbaugruppen enthalten sind habe ich nun so gelöst, dass ich Prüfe ob das Teil schon in meinem Array enthalten ist. Wenn ja wird es kein zweites Mal reingeschrieben.
Somit habe ich jedes Teil nur einmal mit der Gesamtstückzahl in meiner Liste.

Eigentlich bin ich jetzt auch fertig.
Ich muss das Makro noch nach Fehlern oder Vereinfachungen durchforsten, dann geht‘s mal in die Erprobung.
Nach dem du mir bei der Programmierung sehr geholfen hast und es vielleicht noch andere da Draußen gibt die das Makro auch als Anregung brauchen können stelle ich es gerne jedem zur Verfügung. (Vielleicht gibt’s ja ein paar Vorschläge zur Verbesserung)

Danke nochmals Ralf für deine Hilfe.
Mfg
3D-User

Code:

---

Option Explicit
Dim BSArray(200, 10) As String      'Zeilen mit Brennschnitten (Parent, Teilenummer,...)
Dim LSArray(200, 10) As String      'Zeilen mit Laserschnitten (Parent, Teilenummer,...)
Dim BauGrArray(200, 2) As String    'Liste aller Baugruppen Teilenummer und Benennung
Dim BSArrayBauGr() As Variant      'Liste aller Baugruppen mit Brennschnittteilen (Sortiert)
Dim LSArrayBauGr() As Variant      'Liste aller Baugruppen mit Laserschnittteilen (Sortiert)
Dim iZeileBS, iZeileLS As Integer
Dim iZeileBSBgr, iZeileLSBgr, iZeileBGr As Integer
Dim i, ii, iii, x As Integer

Public Sub BomTest()
    Dim sBom As String
    Dim oDoc As AssemblyDocument
    Set oDoc = ThisApplication.ActiveDocument
    Dim fso As New FileSystemObject
    Dim byWert As Byte
    Dim uFolder, oPfad, FileName As String
    Dim oBOM As BOM
    Set oBOM = oDoc.ComponentDefinition.BOM
    Dim oBomRow As BOMRow
    Dim BomTypeStruktur As String
    Dim oStructuredBOMView As BOMView
    iZeileLS = 0
    iZeileBS = 0
    iZeileBSBgr = 0
    iZeileLSBgr = 0
    iZeileBGr = 1
   
    'Stücklsite wir auf "Strukturuert" gestellt
    oBOM.StructuredViewFirstLevelOnly = False
    oBOM.StructuredViewEnabled = True
    Set oStructuredBOMView = oBOM.BOMViews.Item("Strukturiert")
    'Set oStructuredBOMView = oBOM.BOMViews.Item("nur Bauteile")
   
    'Stückliste wird ausgelesen und in Array's gespeichert
    addZeile "", oStructuredBOMView.BOMRows

    'Listen der Hauptbaugruppen wird erstellt und sortiert
    addHauptBG

    'Brennschnittstückliste erstellen
    addExcel
   
    'Hinweis zum Ende des Exports
    MsgBox "Stücklistenexport war erfolgreich!", vbOKOnly, "Stücklistenexport"
End Sub

Private Function addZeile(Parent As String, oBomRows As BOMRowsEnumerator)
    Dim oAsmDoc As AssemblyDocument
    Set oAsmDoc = ThisApplication.ActiveDocument
    Dim oPart As Document
    Set oPart = ThisApplication.ActiveDocument
    Dim oBomRow As BOMRow
    Dim sRow As String
    Dim sCol() As String
    Dim iSpalte As Integer
    Dim oProduktmarke, oArtikelstatus, oProduktgruppe, oFullDocumentName As String
    Dim oTextBSZ As String
    Dim oPartNumber As String
    On Error Resume Next
           
    'Oberste Baugruppe wird in die Baugruppenliste geschreiben
    BauGrArray(1, 1) = oPart.PropertySets(3).Item("Part Number").Value
    BauGrArray(1, 2) = oPart.PropertySets(1).Item("Title").Value
         
    For Each oBomRow In oBomRows
        ReDim sCol(10) 'die Variablen "sCol()" wird geleert
       
        'Variablen werden Werte aus den iProperty zugewiesen
        oProduktmarke = oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Produktmarke").Value
        oPartNumber = oBomRow.ComponentDefinitions(1).Document.PropertySets(3).Item("Part Number").Value
        oArtikelstatus = oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Artikelstatus").Value
        oProduktgruppe = oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Produktgruppe").Value
        oFullDocumentName = oBomRow.ComponentDefinitions(1).Document.FullDocumentName
       
        'ArrayFelder werden zugewiesen
        sCol(1) = Parent
        sCol(2) = oProduktmarke & oPartNumber
        sCol(3) = TeileAnz(oPartNumber, oAsmDoc) 'oBomRow.TotalQuantity
        sCol(4) = oBomRow.ComponentDefinitions(1).Document.PropertySets(1).Item("Title").Value
        sCol(5) = oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Länge").Value
        sCol(6) = oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Breite").Value
        sCol(7) = MatStärke(oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Material/Norm").Value)
        sCol(8) = oBomRow.ComponentDefinitions(1).Document.PropertySets(3).Item("Material").Value
        sCol(9) = oBomRow.ComponentDefinitions(1).Document.PropertySets(1).Item("Revision Number").Value
        sCol(10) = Left(oFullDocumentName, Len(oFullDocumentName) - 4) & ".idw"
               
        'oberste Hauptbaugruppe wird zugewiesen wenn keine Unterbaugruppe vorhanden ist
        If Parent = "" Then sCol(1) = oPart.PropertySets(3).Item("Part Number").Value

        'Alle Datenfelder werden in zwei Arrays (BSZ/LSZ) gespeichert
        If oProduktgruppe = "MP" Then
            If oArtikelstatus = "7" Then 'Artikelstatus "7" = Brennschnittteil
                'Prüfen ob das Teil schon in der Stückliste enthalten ist
                For iii = 1 To iZeileBS
                    If BSArray(iii, 2) = sCol(2) Then GoTo NoNeuBS
                Next iii
                'Teil wird in das Array hinzugefügt
 
                iZeileBS = iZeileBS + 1
                For iSpalte = 1 To 10
                    BSArray(iZeileBS, iSpalte) = sCol(iSpalte)
                Next iSpalte
            End If
NoNeuBS:
            If oArtikelstatus = "8" Then 'Artikelstatus "8" = Laserschnittteil
                'Prüfen ob das Teil schon in der Stückliste enthalten ist
                For iii = 1 To iZeileLS
                    If LSArray(iii, 2) = sCol(2) Then GoTo NoNeuLS
                Next iii
                'Teil wird in das Array hinzugefügt
                iZeileLS = iZeileLS + 1
                    For iSpalte = 1 To 10
                    LSArray(iZeileLS, iSpalte) = sCol(iSpalte)
                Next iSpalte
            End If
NoNeuLS:
        End If
       
        'Benennung der Baugruppen wird gespeichert
        If Right(oBomRow.ReferencedFileDescriptor.FullFileName, 4) = ".iam" Then
            iZeileBGr = iZeileBGr + 1
            BauGrArray(iZeileBGr, 1) = oBomRow.ComponentDefinitions(1).Document.PropertySets(3).Item("Part Number").Value
            BauGrArray(iZeileBGr, 2) = oBomRow.ComponentDefinitions(1).Document.PropertySets(1).Item("Title").Value
        End If
       
        'Unterbaugruppen werden aufgelöst(rekursiver Sub aufruf!)
        If Not oBomRow.ChildRows Is Nothing Then addZeile oPartNumber, oBomRow.ChildRows
    Next
End Function

Private Function TeileAnz(TeileNr2, oAsmDoc) As Integer
    'Gesamtanzahl der Einzelteile wird aus der Stückliste (in der .iam) ausgelesen
    Dim oBOM As BOM
    Dim oBomRow As BOMRow
    Dim oCompDef As ComponentDefinition
    Dim oPropset As PropertySet
    Dim oBOMView As BOMView
    Set oBOM = oAsmDoc.ComponentDefinition.BOM
    If oBOM.PartsOnlyViewEnabled = False Then oBOM.PartsOnlyViewEnabled = True
    For Each oBOMView In oBOM.BOMViews
        If oBOMView.ViewType = kPartsOnlyBOMViewType Then
        Exit For
        End If
    Next
    For Each oBomRow In oBOMView.BOMRows
        Set oCompDef = oBomRow.ComponentDefinitions.Item(1)
        Set oPropset = oCompDef.Document.PropertySets.Item("Design Tracking Properties")
        If oPropset.Item("Part Number").Value = TeileNr2 Then
            TeileAnz = oBomRow.ItemQuantity
            Exit For
        End If
    Next
End Function

Private Sub addHauptBG() 'Listen der Hauptbaugruppen wird erstellt
    'Brennschnitte
    ReDim Preserve BSArrayBauGr(iZeileBS)
    For i = 1 To iZeileBS
        For ii = 1 To iZeileBSBgr
            If BSArrayBauGr(ii) = BSArray(i, 1) Then GoTo nextBG
        Next ii
        iZeileBSBgr = iZeileBSBgr + 1
        BSArrayBauGr(iZeileBSBgr) = BSArray(i, 1)
nextBG:
    Next i
    ReDim Preserve BSArrayBauGr(iZeileBSBgr)
    Call BubbleSort(BSArrayBauGr)
   
    'Laserschnitte
    ReDim Preserve LSArrayBauGr(iZeileLS)
    For i = 1 To iZeileLS
        For ii = 1 To iZeileLSBgr
            If LSArrayBauGr(ii) = LSArray(i, 1) Then GoTo nextLG
        Next ii
        iZeileLSBgr = iZeileLSBgr + 1
        LSArrayBauGr(iZeileLSBgr) = LSArray(i, 1)
nextLG:
    Next i
    ReDim Preserve LSArrayBauGr(iZeileLSBgr)
    Call BubbleSort(LSArrayBauGr)
End Sub

Private Function BubbleSort(vArray As Variant, Optional Ascending As Boolean = True)
'Ascending = True: aufsteigend sortieren
  If Not IsArray(vArray) Then Exit Function
  Dim Mark As Long, i As Long, EndIdx As Long, StartIdx As Long
  Dim Temp As Variant
  EndIdx = UBound(vArray)
  StartIdx = LBound(vArray)
  Do While EndIdx > StartIdx
    Mark = StartIdx
    For i = StartIdx To EndIdx - 1
      If vArray(i) > vArray(i + 1) Eqv Ascending Then
        Temp = vArray(i)
        vArray(i) = vArray(i + 1)
        vArray(i + 1) = Temp
        Mark = i
      End If
    Next i
    EndIdx = Mark
  Loop
End Function

Private Function MatStärke(MatNorm As String)
    'Die Blechstärke wird aus der "Material/Norm" gefiltert (Blech 30 > 30)
    If Left(MatNorm, 5) = "Blech" Then
        MatStärke = Right(MatNorm, Len(MatNorm) - 6)
        ElseIf Left(MatNorm, 11) = "Tränenblech" Then
        MatStärke = "TrB " & Right(MatNorm, Len(MatNorm) - 12)
        ElseIf Left(MatNorm, 11) = "Riffelblech" Then
        MatStärke = "RiB " & Right(MatNorm, Len(MatNorm) - 12)
        ElseIf Left(MatNorm, 9) = "Lochblech" Then
        MatStärke = "LoB " & Right(MatNorm, Len(MatNorm) - 10)
    End If
End Function

Private Sub addExcel()
    Dim oAsmDoc As AssemblyDocument
    Set oAsmDoc = ThisApplication.ActiveDocument
    Dim oAsmName As String
    Dim oTextBSZ, ExcelBlatt As String
    Dim oFolderEXP As String
    Dim oFolderSTL As String
    Dim oFolderSTLu As String
    Dim BSSVorlage, oFolderVOR As String
    Dim ExcelFileName As String
    Dim HauptGBBenennung As String
    Dim ExcelZeile As Integer
    Dim rngZelle As Range
    Dim strText As String
    Dim intPos As Integer

    'Vorläufig
    oAsmName = Left(oAsmDoc.DisplayName, Len(oAsmDoc.DisplayName) - 4)
    oFolderEXP = "N:\Department\Technik\Datenexport\"
    oFolderVOR = "N:\Department\Technik\Datenexport\"      '< Hauptordner für den Export
    oFolderSTL = oFolderEXP & "1 - Stücklisten\"            '< Speicherort der BSStücklisten
    oFolderSTLu = oFolderSTL & Left(oAsmName, 3)            '< Unterordner für die Stückliste
   
    'Prüfen ob es die benötigten Ordner gibt, wenn nicht werden sie erstellt
    Call CreateFolder.CreateFolder(oFolderEXP)
    Call CreateFolder.CreateFolder(oFolderSTL)
    Call CreateFolder.CreateFolder(oFolderSTLu)

    'Kopiert die Vorlage .xls in den Unterordner und benennt die Vorlage nach der Hauptbaugruppe
    BSSVorlage = oFolderVOR & "0 - Vorlagen\BSSVorlage.xls" '< Vorlagedatei für die Excel-Stückliste
    ExcelFileName = oFolderSTLu & "\" & oAsmName & " - " & oAsmDoc.PropertySets(1).Item("Title").Value & ".xls"
    FileCopy BSSVorlage, ExcelFileName

    'Excel-Datei wird geöffnet
    Dim oExl As New Excel.Application
    oExl.Workbooks.Open (ExcelFileName)
           
    'Excel Tabellenkopf wird geschreiben
    oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(2, 2) = oAsmDoc.PropertySets(4).Item("Produktmarke").Value & oAsmName
    oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(3, 2) = oAsmDoc.PropertySets(1).Item("Title").Value
    oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(4, 2) = oAsmDoc.PropertySets(2).Item("Category").Value

    'Brennschnitte werden in die Excel Tabell übertragen
    ExcelZeile = 11
    For i = 1 To iZeileBSBgr
        For ii = 1 To iZeileBGr
            If BSArrayBauGr(i) = BauGrArray(ii, 1) Then
                HauptGBBenennung = BauGrArray(ii, 1) & " " & BauGrArray(ii, 2)
                oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "C").Font.Bold = True
                oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "C") = HauptGBBenennung
                ExcelZeile = ExcelZeile + 1
                For iii = 1 To iZeileBS
                    If BSArrayBauGr(i) = BSArray(iii, 1) Then
                        'Zusatztext aus der .idw wird ausgelesen
                        oTextBSZ = iPropTextBSZ(BSArray(iii, 10))
                        If oTextBSZ <> "" Then oTextBSZ = " (" & oTextBSZ & ")"
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "A") = BSArray(iii, 2)
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "B") = BSArray(iii, 3)
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "C") = BSArray(iii, 4) & oTextBSZ
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "D") = BSArray(iii, 5)
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "E") = BSArray(iii, 6)
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "F") = BSArray(iii, 7)
                        oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "G") = BSArray(iii, 8)
                        'wenn ein Zusatztext gefunden wurde wird dieser in der ExcelZelle Fett dargestellt
                        If oTextBSZ <> "" Then
                            Set rngZelle = oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(ExcelZeile, "C") '[B1] suche in Zelle B1
                            strText = oTextBSZ 'Wort, das in der Zelle gesucht werden soll
                            intPos = InStr(rngZelle.Value, strText) 'Sucht das Wort in der Zelle
                            If intPos > 0 Then 'Wenn das Wort in der Zelle enthalten ist, dann :
                                With rngZelle.Characters(Start:=intPos, Length:=Len(strText)).Font
                                    '.Color = vbRed 'Rot
                                    .Bold = True 'Fett
                                End With
                            End If
                        End If
                        ExcelZeile = ExcelZeile + 1
                    End If
                Next iii
            End If
        Next ii
    Next i

    'Laserschnitte werden in die Excel Tabell übertragen
    ExcelZeile = 11
    For i = 1 To iZeileLSBgr
        For ii = 1 To iZeileBGr
            If LSArrayBauGr(i) = BauGrArray(ii, 1) Then
                HauptGBBenennung = BauGrArray(ii, 1) & " " & BauGrArray(ii, 2)
                oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "C").Font.Bold = True
                oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "C") = HauptGBBenennung
                ExcelZeile = ExcelZeile + 1
                For iii = 1 To iZeileLS
                    If LSArrayBauGr(i) = LSArray(iii, 1) Then
                        'Zusatztext aus der .idw wird ausgelesen
                        oTextBSZ = iPropTextBSZ(LSArray(iii, 10))
                        If oTextBSZ <> "" Then oTextBSZ = " (" & oTextBSZ & ")"
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "A") = LSArray(iii, 2)
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "B") = LSArray(iii, 3)
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "C") = LSArray(iii, 4) & oTextBSZ
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "D") = LSArray(iii, 5)
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "E") = LSArray(iii, 6)
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "F") = LSArray(iii, 7)
                        oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "G") = LSArray(iii, 8)
                        'wenn ein Zusatztext gefunden wurde wird dieser in der ExcelZelle Fett dargestellt
                        If oTextBSZ <> "" Then
                            Set rngZelle = oExl.ActiveWorkbook.Sheets("Laserschnitt").Cells(ExcelZeile, "C") '[B1] suche in Zelle B1
                            strText = oTextBSZ 'Wort, das in der Zelle gesucht werden soll
                            intPos = InStr(rngZelle.Value, strText) 'Sucht das Wort in der Zelle
                            If intPos > 0 Then 'Wenn das Wort in der Zelle enthalten ist, dann :
                                With rngZelle.Characters(Start:=intPos, Length:=Len(strText)).Font
                                    '.Color = vbRed 'Rot
                                    .Bold = True 'Fett
                                End With
                            End If
                        End If
                        ExcelZeile = ExcelZeile + 1
                    End If
                Next iii
            End If
        Next ii
    Next i
    oExl.ActiveWorkbook.Save
    oExl.ActiveWorkbook.Close
End Sub

Private Function iPropTextBSZ(sFile As String) As String
    Dim oAppr As New ApprenticeServerComponent
    Dim oApprDoc As ApprenticeServerDrawingDocument
    Set oApprDoc = oAppr.Open(sFile)
    Dim oProp As Property
    For Each oProp In oApprDoc.PropertySets.Item("inventor user defined properties")
        If oProp.Name = "TextBSZ" Then
            iPropTextBSZ = oProp.Value
        End If
    Next
    Call oApprDoc.Close
    Set oAppr = Nothing
End Function

---

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin

Jetzt hab ich's verstanden. Stimmt, die Duplikatsprüfung und -verhinderung muss mit dazu.

In der Zeile

Code:

---

sCol(3) = TeileAnz(oPartNumber, oAsmDoc) 'oBomRow.TotalQuantity

---

übergibst du die Baugruppe nur um wieder auf die Stückliste zu kommen. Du könntest da gleich oBom übergeben und dir drei Codezeilen sparen. 

Ansonsten könntest du noch ganz viel Wert- und Typenprüfung einbauen, um alles was schief gehen könnte vorher zu verhindern oder zu umgehen. Das hängt ein bißchen davon ab ob du das Makro allein benutzt oder verteilst. Als Alleinutzer verzichte ich häufig drauf. Man(n) ist ja faul.

Und dann wechselst du zu Vb.Net, kopierst deinen Code in eine dll, paßt die Syntax an, spendierst dem Tool noch einen schönen Button und einen Konfigurationsdialog in dem die Parameter (z.B. Pfade) geändert werden können. 

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf
Danke für deine Tipps!

Das mit der oBom Übergabe habe ich noch nicht ganz kapiert!
Anstelle von …, oAsmDoc könnte man oBom übergeben, aber oBom ist in dieser Sub nicht deklariert?

Das mit der Datenprüfung habe ich schon Großteils in meinem "iPropety-Manger" erledigt.

Das mit Vb.Net ist mein großes Ziel, aber ich Drau mich noch nicht drüber.
Der Umfang der Syntaxänderung ist für mich noch nicht abschätzbar.

Aber gleich noch eine Frage zu diesem Makro:
Du hast mir ja gezeigt wie ich schnell ein iProperty aus der .idw rausholen kann.
Kann ich damit auch die Zeichnung öffnen und das Blatt2 als .dxf rausspeichern?
Diese Funktion habe ich ja schon mit „For Each oRefDoc …“ komplett programmiert.
Wie würde denn die Zeile zum Öffnen der Zeichnung ausschauen?

(PS: Ich hoffe ich gehe dir mit meinen Fragen nicht auf die Nerven?)
Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Sorry, war dabei in der Zeile verrutscht. Du hast in der Funktion nur BOMRows statt oBOM. Mein Fehler, äh nein das ein Test. Du hast bestanden. 

Den Sprung sollte man früh wagen und mit einem kleinen Projekt beginnen. Ein größeres Projekt "erschlägt" einen erstmal mit Fehlermeldungen. Viele davon sind schnell behoben, aber die bloße Menge deprimiert erstmal.
Ich fürchte die VBA-Umgebung stirbt bzw. wird durch iLogic ersetzt. Wenn dann alle Projekte auf einen Schlag nicht mehr laufen... 

Ich hab's nicht getestet:

Code:

---

Private Sub ExportDXFWithApprentice()

Dim sFile as String
sFile = ""          '<--- hier mußt du den FullDocumentName deiner IDW einfügen.

Dim oAppr As New ApprenticeServerComponent

Dim oApprDoc As ApprenticeServerDrawingDocument
Set oApprDoc = oAppr.Open(sFile)

Call oApprDoc.Sheets.Item(2).Activate    '<--- das könnte schief gehen, wenn es kein Blatt2 gibt, Blatt2 auf nicht drucken reicht glaub ich auch das es kracht bzw. das Blatt3 als Blatt2 gedruckt wird

Dim DXFAddIn As TranslatorAddIn
Set DXFAddIn = oAppr.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")

Dim oContext As TranslationContext
Set oContext = oAppr.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism

Dim oOptions As NameValueMap
Set oOptions = oAppr.TransientObjects.CreateNameValueMap

Dim oDataMedium As DataMedium
Set oDataMedium = oAppr.TransientObjects.CreateDataMedium

If DXFAddIn.HasSaveCopyAsOptions(oApprDoc, oContext, oOptions) Then

    Dim strIniFile As String
    strIniFile = "Pfad\zur\DXF\export.ini"    '<--- hier kann man u.a. einstellen das nur das aktive Blatt exportiert werden soll

    oOptions.Value("Export_Acad_IniFile") = strIniFile
End If

oDataMedium.Filename = "c:\temp\dxfout.dxf"

Call DXFAddIn.SaveCopyAs(oApprDoc, oContext, oOptions, oDataMedium)

Call oApprDoc.Close

Call oAppr.Close
End Sub

---

Wenn mich Fragen nerven würden, wäre ich in einem Forum falsch oder? 

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Mit der Sub “ExportDXFWithApprentice()” komme ich nicht klar.
Ich habe alle Pfade gesetzt aber ich komme nicht weiter.

Set oApprDoc = oAppr.Open(sFile) >>> da öffnet sich die Zeichnung nicht!
Call oApprDoc.Sheets.Item(2).Activate >>>> Fehlermeldung
Set DXFAddIn = oAppr.ApplicationAddIns….>>>> Fehlermeldung Datentyp unverträglich….

Kannst du dir's nochmal anschauen.

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Das hat man davon, wenn man's selber nicht ausprobiert. Den DXF-Translator gibt's im ApprenticeServer nicht, Das aktive Blatt läßt sich mit Apprentice nicht setzen. So wird das nix. Leider 

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Macht nichts, ich hab‘s schon auf die herkömmliche Weise programmiert.
Eigentlich bin ich jetzt wirklich fertig mit dem Projekt.
Ich hab ein schönes Eingabefenster gemacht und eine Fortschrittsanzeige die den Status der einzelnen Funktionen anzeigt!

Ich werde jetzt mal versuchen ein kleineres Projekt nach VB.Net zu portieren.
Dazu werde ich sicherlich wieder deine Hilfe brauchen.

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

So, jetzt hab ich doch noch ein Problem und keine Lösung dazu.

In einem anderen Makro exportiere ich die Stückliste in eine .txt Datei für den Import in unser ERP-System.
Das Funktioniert auch schon alles so wie es sein soll, nur die Sortierung der Stückliste macht Probleme.
Ich sortiere die Stückliste nach „oBomRow.ItemNumber“
Ohne Sortierung sind die Teile ziemlich durcheinander.
Nach der Sortierung mir „QuickSortMultiDim“ (http://www.vbarchiv.net/tipps/tipp_1881-2-dimensionales-array-nach-beliebiger-spalte-sortieren.html) ist die Reihenfolge fast perfekt.

Leider wird nach der ersten Zahl sortiert!
Das Ergebnis ist: 1 - 1.1 - 1.2 - 1.3 – 10 – 11 – 12 – 13 - …… 19 – 2 - 2.1 - 2.2 – 21 – 22 - ….
So soll es sein: 1 - 1.1 - 1.2 - 1.3 – 2 - 2.1 - 2.2 – 3 - 3.1 – 3.2 – 3.3 - 4 ….

Wie kann ich die Sortierung ändern damit der Zweite Fall heraus kommt?

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Du vergleichst Strings miteinander und die werden zeichenweise von vorn verglichen. Du könntest versuchen die Positionsnummern vor dem Vergleich mit der CDbl-Funktion in Zahlen zu konvertieren. Ich rate mal hier:

Code:

---

While (vSort(i, index - 1) < x): i = i + 1: Wend
    While (vSort(j, index - 1) > x): j = j - 1: Wend

---

ändern in:

Code:

---

While (CDbl(vSort(i, index - 1)) < CDbl(x)): i = i + 1: Wend
    While (CDbl(vSort(j, index - 1)) > CDbl(x)): j = j - 1: Wend

---

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Leider nein!
Das Ergebnis ist als würden die Trennpunkte einfach ignoriert!
Ich hab im Internet ein wenig gesucht, scheinbar gibt es da keine Lösung.

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Selbst wenn es erstmal funktionieren würde, spätestens wenn ein zweiter Punkt (also 1.1.1) auftaucht geht's in die Binsen. 

Man müßte in jeder Stücklistenebene die höchste Nummer finden und je nach Ziffernanzahl alle anderen entsprechend mit führenden Nullen auffüllen. Irgendwie auch doof. Was wäre, wenn man die Positionsnummern in einzelne Spalten verteilt und dann sortiert? Müßte man vorab die Anzahl der Ebenen ermitteln. Auch nicht wirklich besser.

Ganz blöd gefragt, nur weil in der txt-Datei die falsche Reihenfolge steht muß das ja euer ERP-System nicht jucken. Wenn es die Positionsnummern als solche übernimmt, sollte es sie auch korrekt sortieren können oder?

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf

Die Sortierung über „oBomRow.ItemNumber“ hab ich umgangen in dem ich die Stückliste in einem Array nach „Parent“ sortiert habe. Klappt wunderbar.

Jetzt noch ein neue Frage:

    oBOM.StructuredViewFirstLevelOnly = False
    oBOM.StructuredViewEnabled = True
    Set oStructuredBOMView = oBOM.BOMViews.Item("Strukturiert")
    .......
    Dim oPart As Document
    Set oPart = ThisApplication.ActiveDocument
    Dim oBomRow As BOMRow
    'On Error Resume Next
    .....
Fehler > PMarke = BomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("Produktmarke").Value
......
Fehler > If oBomRow.ComponentDefinitions(1).Document.PropertySets(4).Item("NoAXBom").Value = False Then

Ich hab da einen Fehler wenn ich „On Error Resume Next“ entferne.
(beides sind eigene iProperty's)
"Laufzeitfehler 91:
Objektvariable oder With-Blockfariable nicht festgeleg"

Wie müssten die beiden Zeilen richtig lauten?

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi

Hmm, falls das kein Abschreibfehler ist, fehlt in der ersten Zeile das "o" von oBomRow.
Willst du in der zweiten Zeile wissen ob das iProp leer ist? Das wäre dann = ""
Oder steht in dem iProp wirklich "False" drin? Das wäre dann = "False" (Anrührungszeichen fehlten)

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Wo das "o" hingekommen ist weiß ich nicht, ist aber im Code vorhanden!
Das iProperty "NoAXBom" ist vom Typ Boolean

Das Komische ist das der Code mit "On Error Resume Next" einwandfrei funktioniert!

mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Und wenn du oBomRow.ComponentDefinitions(1).Document erstmal einem Document-Objekt zuweist und dann mit oDoc.PropertySets(4).Item("Produktmarke").Value versuchst? Wenn Inventor irgendwo in der Kette ein Problem hat, hilft nur sie scheibchenweise durchzugehen.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ralf
Nein, das Teilen der Kette hat nichts gebracht.

Aber ich glaube ich habe das Problem gefunden.
Das abgefragte  iProperty ist nicht in allen Modellen vorhanden!
Nur dann wenn es schon einmal auf „False“ gesetzt wurde, wird es erstellt.

Ich denke in diesem Fall kann ich es so belassen?

Mfg
3D-User

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Kann man. Aber damit setzt du z.B. in der If-Abfrage das nicht Existieren des iProps gleich dem Existieren des iProps mit Wert True. Wenn der Programmablauf in beiden Fällen gleich wäre, geht's.
Ich mag On Error Resume Next nicht, weil man sich oft über dadurch ausgelöstes seltsames Programmverhalten wundert.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP