---

Hallo zusammen,

nachdem ich nun schon eine Schar an iParts-Bauteilen generiert habe, die ich als iAssembies zusammensetze, denke ich jetzt über den nächsten Schritt nach, aus den iPart-Kindern wieder richtige Bauteile zu konvertieren, damit ich die Bemaßungen abrufen kann und ggf. noch spezielle Kundenwünsche ergänzen kann.

Also die Ausgangslage sind:

1) iParts für Kolben/Stangen/Flansche etc
2) iAssemblies als Unterbaugruppen, die den Kolben etc. die Dichtungen verpassen
3) Ganz normale Bauteile für spezielle Kundenanforderungen
4) eine Zusammenbau-iAssembly, die die Teile aus 1),2) und 3) zum Endprodukt vereint.

Um
a) Einzelteilzeichnungen zu erstellen und
b) dabei die Bemaßungen abzurufen (geht ja bei iParts nicht) und
c) den Zeichnungstand zu erhalten egal ob sich die iParts entwicklen und
d) keine Aktualisierungen der Zusammenbau-iAssembly mehr zu erhalten (siehe c)

benötige ich ein Makro, dass ich bei der Zusammenbau-iAssembly ausführe und dass mir
1. rekursiv alle iParts der (Unter-)Baugruppen öffnet,
2. das Mutterbauteil auf das benötigte Kind umstellt
3. das Mutterkind als .ipt mit dem Kindernamen in einen anderen Ordner abspeichert
4. die iPart Tabelle des nun eigenständigen Bauteils löscht und
5. (Finale) in der iAssembly das iPart-Bauteil gegen das eigenständige Bauteil ersetzt,
(mit 6. Am liebsten, in dem die Abhängigkeiten beibehalten werden können  vielleicht kann man die Abhängigkeiten vor dem Ersetzen als iMate bei dem eigenständig gewordenen Bauteil anlegt ?!?!  )

Aber 1-5. ist sicherlich schon ein kühnes Projekt, vielleicht könnt Ihr mir helfen - Danke für jede Idee dazu!!!

Viele Grüße und ein schönes Wochenende,
Stefan

------------------
IV2008

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

---

Moin

1. Rekursion durch Baugruppen und Unterbaugruppen hab ich hier schon öfter beschrieben.
2. Aktiv schalten des richtigen Kindes geschieht über das Setzen der DefaultRow der iPartTable. Hatten wir die Tage erst einen Beitrag dazu.
3. Sollte mit SaveCopy zu erledigen sein. In der Programmierungshilfe ist dazu mM ein Beispiel. Das Zerlegen und wieder neu Zusammensetzen von Zielpfad und neuem Dateinamen hatten wir hier auch schon mehrfach.
4. Das Löschen der iPart-Tabelle sollte reichen, um ein normales Bauteil draus zu machen.
5. Da das neue Bauteil eine Kopie des verbauten Teiles ist, müßten die ID's der Flächen und Kanten identisch sein. Beim Ersetzen sollten die Abhängigkeiten ohne weiteres Zutun erhalten bleiben. Man kann das "von Hand" testen. Im Windows-Explorer eine Kopie eines Bauteils einer BG erzeugen und mit "Komponente ersetzen" austauschen.

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

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

---

Modelle.zip

Hallo VBA-Fangemeinde, hallo Ralf,

ich habe alle Hinweise bestmöglich gecheckt, jedoch laufen manche Programme nicht (deshalb die Forumseinträge) und die gegebenen Lösungen kann ich unter Unmständen nicht nutzen, da ich sie nicht tief genug verstehe. Auch ist mein Schulenglisch oft nicht ausreichend, die Hilfe geeignet zu verstehen.

Aber ich habe da mal (bestmöglich) was vorbereitet...

Als Start-Code habe ich

Code:

---

Public Sub BOMQuery()
    Dim oDoc As AssemblyDocument
    Set oDoc = ThisApplication.ActiveDocument
    If oDoc.DocumentType <> kAssemblyDocumentObject Then Exit Sub ' Assembly, sonst beenden
   
    Dim oBOM As BOM
    Set oBOM = oDoc.ComponentDefinition.BOM    ' Set a reference to the BOM

    oBOM.StructuredViewFirstLevelOnly = False
    oBOM.StructuredViewEnabled = True    ' Make sure that the structured view is enabled.

    Dim oBOMView As BOMView
    Set oBOMView = oBOM.BOMViews.Item("Strukturiert")    'Set a reference to the "Structured" BOMView

    Call QueryBOMRowProperties(oBOMView.BOMRows)
End Sub

Private Sub QueryBOMRowProperties(oBOMRows As BOMRowsEnumerator)    ' Iterate through the contents of the BOM Rows.
    Dim l As Long
   
    Dim i As Long
    For i = 1 To oBOMRows.count
        Dim oRow As BOMRow
        Set oRow = oBOMRows.Item(i)        ' Get the current row.

        Dim oCompDef As ComponentDefinition
        Set oCompDef = oRow.ComponentDefinitions.Item(1)        'Set a reference to the primary ComponentDefinition of the row

        Dim oPartNumProperty As Property
        Dim oDescripProperty As Property

        If TypeOf oCompDef Is VirtualComponentDefinition Then
            l = oCompDef.Document
           
            Set oPartNumProperty = oCompDef.PropertySets.Item("Design Tracking Properties").Item("Part Number")            'Get the file property that contains the "Part Number" The file property is obtained from the virtual component definition
            Set oDescripProperty = oCompDef.PropertySets.Item("Design Tracking Properties").Item("Description") 'Get the file property that contains the "Description"

            Debug.Print l; Tab(15); oRow.ItemNumber; Tab(25); oRow.ItemQuantity; Tab(30); _
                oPartNumProperty.Value; Tab(70); oDescripProperty.Value
        Else
            l = oCompDef.Document
            Set oPartNumProperty = oCompDef.Document.PropertySets.Item("Design Tracking Properties").Item("Part Number") 'The file property is obtained from the parent document of the associated ComponentDefinition.
            Set oDescripProperty = oCompDef.Document.PropertySets.Item("Design Tracking Properties").Item("Description") 'Get the file property that contains the "Description"

            Debug.Print l; Tab(15); oRow.ItemNumber; Tab(25); oRow.ItemQuantity; Tab(30); _
                oPartNumProperty.Value; Tab(70); oDescripProperty.Value

            If Not oRow.ChildRows Is Nothing Then
                Call QueryBOMRowProperties(oRow.ChildRows)            'Recursively iterate child rows if present.
            End If

        End If
    Next
End Sub

---

und vorallem habe ich saubere Modelle  generiert, anhand dessen ein Testen möglich ist.

Sie bestehen aus 3 Aufträgen, die jeweils eine Zusammenstellungsbaugruppe enthalten.
Diese hat einen auftragsspezifischen Deckel und eine iAssembly Baugruppe, die wiederum eine (Unter-) iAssembly Baugruppe hat.

Was ich nicht hinkriege ist das Holen der Pfade der iAssembly Baugruppen und iPart Bauteile. Somit kann ich leider auch das SaveCopy nicht machen.

Bitte helft mir weiter, ich möchte gerne für den jeweiligen Auftrag die iPart-Kinder als normale Bauteile unter dem Auftrag speichern, und in der Baugruppe ersetzen, so dass die Abhängigkeiten erhalten bleiben.

Danke für Eure Hilfe...
Stefan

------------------
IV2008

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

---

Hallo

Den Bauteilnamen findest du unter iPartFactory.DefaultRow.Partname. Ich knoble da seit Tagen dran rum, aber eine sinnvolle Lösung hab ich nicht gefunden.

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

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

---

Danke Ralf,

dass Du dran warst (/oder sogar noch bist ?!)

Hast Du schon einen Teil der Lösung erstellt?

Ich selber habe leider keinen Pack-an mehr.

Danke nochmal für Dein Engagement,
Stefan

------------------
IV2008

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

---

ModellemitiMates.zip

Hallo Ralf, hallo vba-Kenner,

Michael Puschner hat mir die iMates erklärt und die habe ich nun in die Modelle mit eingebaut. Damit bin ich der Lösung schon viel näher gekommen und kann den Ablauf händisch ausführen - und er klappt super.
In den angehängten Modellen ist im Auftrag 1 das separierte Modell mit abgelegt. Der Ablauf funktioniert (nur) wie folgt:

1. Zusammenbauzeichnung öffnen
2. Sofort speichern unter 'Zusammenstellung-separiert'
3. Alle Elemente von Oben nach unten durchlaufen:
4. Wenn iPart oder iAssembly, dann Kind-Name merken. (bei normalen Bauteil/Assembly nichts machen)
5. iPart/iAssemby öffnen (ist die Mutter)
6. Sofort 'speichern unter' mit Kind-Name in Auftragsordner.
7. Auf das benötigte Kind schalten.
8. Tabelle löschen
9. Erneut speichern (jetzt liegt eigenständiges Bauteil vor) und schließen
10. iPart/iAssemby (Mutter) schließen
11. Jetzt das Element mit 'Komponente ersetzen' gegen das eigenständige Bauteil tauschen. (die iMates sorgen für die weiterhin richtige Positionierung  )
12. weiter mit 4 bis alle abgearbeitet sind, dann
13. finales Speichern der 'Zusammenstellung-separiert'

Folgende Anmerkungen sind wichtig:

A) Sofort nach Öffnen speichern, sonst macht ggf. Inventor eigenständige Zwischenspeicherungen und die wirken sich blöd aus.

B) Wichtiger Hinweis zum Thema iMates: Das erste Element einer iAssembly darf KEIN iPart/iAssembly sein, sondern ein normales Bauteil.
An dem muß das iMates für die übergeordnete Baugruppe angehängt sein.
Deshalb habe ich ein DUMMY-Bauteil eingeführt, dass nur diese Aufgabe hat. Denn die iMates gehen m.E. sonst kaputt (mehrfach überprüft)

Aber wie geschrieben... manuell klappt es mit dem DUMMY richtig gut.

Bitte helft mir mit den vba-Befehlen zum:
a) Durchlaufen der Elemente
b) herausholen des Pfades der Mutter
c) setzen des richtigen Kindes
d) Löschen der Tabelle bei iPart/iAssembly
e) ggf. schließen  und vorallem
f) 'Komponente ersetzen'

Danke für jeden Tipp!

Viel Spaß beim Ausprobieren der Modelle.
Auftrag 2 und 3 ist für Eure Versuche,

Danke Euch schon mal,
Stefan...

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

---

Hi

Schön gibt's woanders, aber testen kann man ja mal:

Code:

---

Option Explicit

Private Sub ExtractAssFromiAss()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    If oApp.Documents.Count = 0 Then
        MsgBox "Es muß mindestens eine Baugruppe geöffnet sein", vbExclamation
        Exit Sub
    End If
   
    If Not oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
        MsgBox "Funktion nur in Baugruppen möglich", vbExclamation
        Exit Sub
    End If
   
    Dim oSourceDoc As AssemblyDocument
    Set oSourceDoc = oApp.ActiveDocument
       
     Dim sBasePath As String
     sBasePath = GetBasePath(oSourceDoc)
   
    '1. neuen Speicherpfad bauen
    Dim sNewFileName As String
    sNewFileName = sBasePath & "\" & GetDocumentName(oSourceDoc) & "-separiert" & Right(oSourceDoc.FullFileName, 4)
   
    '2. Speichern des Zusammenbaus unter neuem Namen
    Call oSourceDoc.SaveAs(sNewFileName, False)
   
    '3. Öffnen der Zusammenbau-Kopie
    Dim oNewAss As AssemblyDocument
    Set oNewAss = oSourceDoc 'oApp.Documents.Open(sNewFileName)
                   
    '4.Rekursiver Durchlauf
    If ProcessRefedDocs(oApp, oNewAss, sBasePath) = False Then
        MsgBox "Es ist ein Fehler aufgetreten", vbCritical
    End If
   
    '5. Baugruppe aktualisieren
    Call oNewAss.BrowserPanes.ActivePane.Update
    Call oNewAss.Update2(True)
       
    '6. Abschließendes Speichern
    Call oNewAss.Save2(True)
   
    '7. Schließen
    'Call oNewAss.Close()
   
End Sub

Private Function ProcessRefedDocs(ByVal oApp As Inventor.Application, ByVal oAssDoc As AssemblyDocument, ByVal sBasePath As String) As Boolean

Dim oRefedDoc As Document
Dim oRefedAss As AssemblyDocument
Dim oRefedPart As PartDocument
Dim oNewDoc As Document

Dim oFileSystem As Object

Dim sOldFileName As String
Dim sNewFileName As String

Dim oOcc As ComponentOccurrence

Set oFileSystem = CreateObject("Scripting.FileSystemObject")

For Each oRefedDoc In oAssDoc.ReferencedDocuments
    If oRefedDoc.DocumentType = kAssemblyDocumentObject Then
        'falls es eine iAssembly ist, extrahieren
        Set oRefedAss = oRefedDoc
        sOldFileName = oRefedAss.FullDocumentName
        If oRefedAss.ComponentDefinition.IsiAssemblyMember Then
            'starte Extraktion
            'neuen Dateinamen generieren
            sNewFileName = sBasePath & "\" & GetDocumentName(oRefedAss) & "-separiert" & Right(oRefedAss.FullFileName, 4)
            'existiert die neue Datei schon, dann muß sie nicht mehr erzeugt werden
            If oFileSystem.FileExists(sNewFileName) = False Then
                Call ExtractiAss(oApp, oRefedAss, sNewFileName)
            End If
           
            'Probieren wir mal die Occurrence auszutauschen
            If Not sNewFileName = "" Then
                For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                    If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sOldFileName Then
                        Call oOcc.Replace(sNewFileName, False)
                    End If
                Next
            End If
           
            'Referenz auf die neue/ausgetauschte Baugruppe setzen, denn die soll weiterbearbeitet werden
            For Each oNewDoc In oAssDoc.ReferencedDocuments
                If oNewDoc.FullDocumentName = sNewFileName Then
                    Set oRefedAss = oNewDoc
                End If
            Next
        End If
       
        Call processRefedDocs(oApp, oRefedAss, sBasePath) ' subassembly
    ElseIf oRefedDoc.DocumentType = kPartDocumentObject Then
        'falls es ein iPart ist, extrahieren
        Set oRefedPart = oRefedDoc
        sOldFileName = oRefedPart.FullDocumentName
        If oRefedPart.ComponentDefinition.IsiPartMember Then
            'starte Extraktion
            'neuen Dateinamen generieren
            sNewFileName = sBasePath & "\" & GetDocumentName(oRefedPart) & "-separiert" & Right(oRefedPart.FullFileName, 4)
            'existiert die neue Datei schon, dann muß sie nicht mehr erzeugt werden
            If oFileSystem.FileExists(sNewFileName) = False Then
                Call ExtractiPart(oApp, oRefedPart, sNewFileName)
            End If
        ElseIf InStr(oRefedPart.FullDocumentName, "DUMMY") Then
            'Dummy-Bauteil nur kopieren
            'neuen Dateinamen generieren
            sNewFileName = sBasePath & "\" & GetDocumentName(oRefedPart) & Right(oRefedPart.FullFileName, 4)
            'existiert die Dummy-Datei schon, dann muß sie nicht mehr erzeugt werden
            If oFileSystem.FileExists(sNewFileName) = False Then
                Call oRefedPart.SaveAs(sNewFileName, False)
            End If
        End If
       
        'Probieren wir mal die Occurrence auszutauschen
        If Not sNewFileName = "" Then
            For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sOldFileName Then
                    Call oOcc.Replace(sNewFileName, False)
                End If
            Next
        End If
    End If
   
    sNewFileName = ""
Next

'bisher nur ein Dummy, da keine Rückgabewerte der Funktionen implementiert sind
ProcessRefedDocs = True

End Function

Private Function GetBasePath(ByVal odoc As Document)

Dim oFileName As String
oFileName = odoc.FullDocumentName

Dim oArray() As String
oArray = Split(oFileName, "\")

Dim sName As String
Dim i As Integer
sName = oArray(LBound(oArray))
For i = 1 To UBound(oArray) - 1
    sName = sName & "\" & oArray(i)
Next
GetBasePath = sName

End Function

Private Function GetDocumentName(ByVal odoc As Document)

Dim oFileName As String
oFileName = odoc.FullDocumentName

Dim oArray() As String
oArray = Split(oFileName, "\")

Dim sName As String
sName = oArray(UBound(oArray))

GetDocumentName = Left(sName, Len(sName) - 4)

End Function

Private Function ExtractiAss(ByVal oApp As Inventor.Application, ByVal oAssDoc As AssemblyDocument, ByVal sNewFileName As String)

Dim oParent As AssemblyDocument
Dim oRow As iAssemblyTableRow
Dim sMemberName As String

'neuen Name generieren
sMemberName = oAssDoc.ComponentDefinition.iAssemblyMember.Row.MemberName

'Mutter öffnen
Set oParent = oApp.Documents.Open(oAssDoc.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName)

'Speichern die erste
Call oParent.SaveAs(sNewFileName, False)

'aktive Zeile setzen
If Not oParent.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMemberName Then
    For Each oRow In oParent.ComponentDefinition.iAssemblyFactory.TableRows
        If oRow.MemberName = sMemberName Then
            oParent.ComponentDefinition.iAssemblyFactory.DefaultRow = oRow
        End If
    Next
End If

'Tabelle löschen
Call oParent.ComponentDefinition.iAssemblyFactory.Delete

'Speichern die zweite
Call oParent.Save

'und schließen
oParent.Close

End Function

Private Function ExtractiPart(ByVal oApp As Inventor.Application, ByVal oPartDoc As PartDocument, ByVal sNewFileName As String)

Dim oParent As PartDocument
Dim oRow As iPartTableRow
Dim sMemberName As String

'neuen Name generieren
sMemberName = oPartDoc.ComponentDefinition.iPartMember.Row.MemberName

'Mutter öffnen
Set oParent = oApp.Documents.Open(oPartDoc.ComponentDefinition.iPartMember.ReferencedDocumentDescriptor.FullDocumentName)

'Speichern die erste
Call oParent.SaveAs(sNewFileName, False)

'aktive Zeile setzen
If Not oParent.ComponentDefinition.iPartFactory.DefaultRow.MemberName = sMemberName Then
    For Each oRow In oParent.ComponentDefinition.iPartFactory.TableRows
        If oRow.MemberName = sMemberName Then
            oParent.ComponentDefinition.iPartFactory.DefaultRow = oRow
        End If
    Next
End If

'Tabelle löschen
Call oParent.ComponentDefinition.iPartFactory.Delete

'Speichern die zweite
Call oParent.Save

'und schließen
oParent.Close

End Function

---

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

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

---

Hallo Ralf,

vielen, vielen Dank für den Code. Der ist wirklich mächtig.

Ich hatte ja händisch Auftrag 1 erarbeitet, so dass alle meine iAssemlies und iParts auf defaultrow = 1.Teil standen.

Beim Ausprobieren Deines Codes beim Auftrag 2 zeigte sich, dass das Rohr mit dem Boden richtigerweise von Auftrag 2 separiert war, der Kolben mit den Führungbänder aber aus Auftrag 1 war, also zu klein.

Wenn Du noch im Stoff bist, hast Du noch einen Tipp, wo der Effekt zustandekommt?

Vielen, vielen Dank nochmals,
Stefan

------------------
IV2008

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

---

Hallo

Ich hab's mit Auftrag 2 und 3 ausprobiert und auch mit der "alten" Version ohne iMates. Grad eben nochmal zur Sicherheit mit den nochmal frisch heruntergeladenen Modellen. Überall kamen korrekte Ergebnisse heraus. Ich bekomme manchmal zu Beginn eine Rückfrage ob ausstehende Änderungen in der Ursprungsbaugruppe aktualisiert werden sollen, die ich mit Ja beantworte. Vielleicht versteckt sich hinter der Aktualisierung das Umschalten auf die richtige Variante, obwohl die eigentlich schon vorher korrekt sein sollte. Da sag ich mal 

Kannst du bitte mal einen Haltepunkt im VBA-Editor auf die Zeile

Code:

---

oParent.ComponentDefinition.iPartFactory.DefaultRow = oRow

---

in der Function ExtractiPart setzen und:
1. Wenn das Programm dort anhält mal den MemberName von oRow und der DefaultRow kontrollieren und
2. Wenn du mit F8 einen Schritt weiter gegangen bist prüfen ob die DefaultRow jetzt den gleichen Membername wie oRow hat?

Oder wird schon die Kolben-kompl-01-separiert.iam statt -03 erstellt? Dann müßtest du o.g. Prüfung in der ExtractiAss machen.

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

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

---

Modell.zip

Hallo Ralf, hallo vba-Kenner,

da ich mit dem Problem nicht weiterkam, habe ich den mächtigen Code von Ralf in für mich verstehbare Abschnitte zerlegt und somit immer tiefer verstanden.

Ergebnis ist ein neu zusammengesetzter Code, der mir eine geöffnete (aktive) Baugruppe extrahiert.

Da es ja auch "normale" Baugruppen geben kann, die erst in tieferen Ebenen iAssemblies und/oder iParts verwenden, wird der Rückgabewert der rekursiven Funktion genutzt. Der Rückgabewert gibt an, ob die obere Baugruppe gespeichert werden muß.

Soweit die Grobbeschreibung:

Code:

---

' Extrahiert aus der aktiven Baugruppe die iParts/iAssemblies raus
Sub ExtractAssFromiAss()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim oSourceDoc As AssemblyDocument
   
    Dim sBasePath As String
    Dim sSepFilename As String
    Dim sVorhandenerFilename As String
   
    Dim ItemTab As Long        ' Rekursionstiefe als Tab-Position bei Debug.Print
    ItemTab = 1
    ' wenn Baugruppe aktiv, dann diese extrahieren
    If oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
        Set oSourceDoc = oApp.ActiveDocument
        ' Zielpfad und Zielname definieren
        sBasePath = GetBasePath(oSourceDoc) & "\Extraktion"
        sVorhandenerFilename = oSourceDoc.FullDocumentName
        sSepFilename = CreateSepFilename(sBasePath, oSourceDoc)
        'Speichern der aktiven Baugruppe unter Separationsnamen
        Debug.Print Tab(ItemTab); "ExtractAssFromiAss: SaveAs: sSepFilename = " & Replace(sSepFilename, sBasePath, "..")
        Call oSourceDoc.SaveAs(sSepFilename, False)
        ' Extrahiere aktive Assembly, wenn true zurück gegeben wurde, konnte Extraktion erfolgreich ausgeführt werden
        If ExtractRefedDocs(oApp, oSourceDoc, sBasePath, ItemTab) Then
            Set oSourceDoc = oApp.Documents.Open(sSepFilename)
            MsgBox "Extraktion erfolgreich abgeschlossen."
        Else
            Set oSourceDoc = oApp.Documents.Open(sVorhandenerFilename)
            MsgBox "Keine Extraktion möglich."
        End If
    Else
        MsgBox "Funktion nur in Baugruppen möglich", vbExclamation
    End If
End Sub

Private Function ExtractRefedDocs(ByVal oApp As Inventor.Application, ByVal oAssDoc As AssemblyDocument, sBasePath As String, ItemTab As Long) As Boolean
    Dim oRefedDoc As Document
    Dim oRefedAss As AssemblyDocument
    Dim oRefedPart As PartDocument
   
    Dim oAssParent As AssemblyDocument          ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
             
    Dim oPartParent As PartDocument            ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow
   
    Dim oNormalesAssDoc As AssemblyDocument    ' für normale Assembly-Abwicklung
   
    Dim sVorhandenerFilename As String
    Dim sSepFilename As String
    Dim sMemberName As String
    Dim sMerkeVorhandenerFilename As String    ' für Kompemsation Anormalie
   
    Dim oOcc As ComponentOccurrence
    Dim oFileSystem As Object
    Set oFileSystem = CreateObject("Scripting.FileSystemObject")

    Dim bAustauschNötig As Boolean, bNormaleAssAustauschen As Boolean
    bAustauschNötig = False
   
    ItemTab = ItemTab + 4
    Debug.Print Tab(ItemTab); "Start ExtractRefedDocs: Start.FullFileName = " & Replace(oAssDoc.FullFileName, sBasePath, "..")
    ' alle referenzierten Komponenten der Assemly durchlaufen
    For Each oRefedDoc In oAssDoc.ReferencedDocuments
        Debug.Print Tab(ItemTab); ">> Komponente = " & Replace(oRefedDoc.FullDocumentName, sBasePath, "..")
       
        sVorhandenerFilename = oRefedDoc.FullDocumentName
        sSepFilename = CreateSepFilename(sBasePath, oRefedDoc)
        ' wenn separiertes File nicht schon vorliegt...
        If Not oFileSystem.FileExists(sSepFilename) Then
            sSepFilename = ""
            'falls es eine Assembly ist, analysieren
            If oRefedDoc.DocumentType = kAssemblyDocumentObject Then
                Set oRefedAss = oRefedDoc
                ' wenn iAssembly, dann ...
                If oRefedAss.ComponentDefinition.IsiAssemblyMember Then
                    sSepFilename = CreateSepFilename(sBasePath, oRefedAss)
                    ' Name des Kindes holen
                    sMemberName = oRefedAss.ComponentDefinition.iAssemblyMember.row.MemberName
                    ' Mutter öffnen
                    Set oAssParent = oApp.Documents.Open(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName)
                    ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                    If Not oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMemberName Then
                        ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                        For Each oAssRow In oAssParent.ComponentDefinition.iAssemblyFactory.TableRows
                            If oAssRow.MemberName = sMemberName Then
                                oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                                Exit For
                            End If
                        Next
                    End If
                   
                    Debug.Print Tab(ItemTab); ">> iAssemblyParent.SaveAs " & Replace(sSepFilename, sBasePath, "..")
                    ' Speichern der iAssembly unter neuem Namen
                    Call oAssParent.SaveAs(sSepFilename, False)
                    ' Tabelle löschen
                    Call oAssParent.ComponentDefinition.iAssemblyFactory.Delete
                    ' Kind der iassembly auswerten, schließt dabei das übergebene Dokument
                    bAustauschNötig = bAustauschNötig Or ExtractRefedDocs(oApp, oAssParent, sBasePath, ItemTab)
                   
                Else
                    ' "normale" iam, aber auch die könnte iParts/iAssemblies enthalten, also Extrahieren
                    Set oRefedAss = oRefedDoc
                    sMerkeVorhandenerFilename = oRefedAss.FullFileName
                    Set oNormalesAssDoc = oApp.Documents.Open(oRefedAss.FullFileName)
                    sSepFilename = CreateSepFilename(sBasePath, oNormalesAssDoc)
                    Call oNormalesAssDoc.SaveAs(sSepFilename, False)
                    ' normale assembly auswerten, schließt dabei das übergebene Dokument
                    bNormaleAssAustauschen = ExtractRefedDocs(oApp, oNormalesAssDoc, sBasePath, ItemTab)
                    bAustauschNötig = bAustauschNötig Or bNormaleAssAustauschen
                    Call oAssDoc.Update
                    If Not bNormaleAssAustauschen Then              ' Ab hier Anormalie-Behandlung
                        sVorhandenerFilename = sSepFilename        ' Austausch der Dateinamen, damit der selbständige
                        sSepFilename = sMerkeVorhandenerFilename    ' Austausch des normalen Assembly rückgetauscht wird.
                    End If
                End If
               
           
            ElseIf oRefedDoc.DocumentType = kPartDocumentObject Then 'falls es ein iPart ist, dann...
                Set oRefedPart = oRefedDoc
                ' prüfe, ob iPart, dann analog extrahieren...
                If oRefedPart.ComponentDefinition.IsiPartMember Then
                    sSepFilename = CreateSepFilename(sBasePath, oRefedPart)
                    ' Name des Kindes holen
                    sMemberName = oRefedPart.ComponentDefinition.iPartMember.row.MemberName
                    ' Mutter öffnen
                    Set oPartParent = oApp.Documents.Open(oRefedPart.ComponentDefinition.iPartMember.ReferencedDocumentDescriptor.FullDocumentName)
                    ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                    If Not (oPartParent.ComponentDefinition.iPartFactory.DefaultRow.MemberName = sMemberName) Then
                        ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                        For Each oPartRow In oPartParent.ComponentDefinition.iPartFactory.TableRows
                            If oPartRow.MemberName = sMemberName Then
                                oPartParent.ComponentDefinition.iPartFactory.DefaultRow = oPartRow
                                Exit For
                            End If
                        Next
                    End If
                    Debug.Print Tab(ItemTab); ">> iPartParent.SaveAs " & Replace(sSepFilename, sBasePath, "..")
                    ' Speichern des iParts unter neuem Namen
                    Call oPartParent.SaveAs(sSepFilename, False)
                    ' Tabelle löschen
                    Call oPartParent.ComponentDefinition.iPartFactory.Delete
                    ' Speichern die zweite und schließen
                    Call oPartParent.Save
                    Call oPartParent.Close
                End If
            End If
        End If
        Call oAssDoc.Update
        ' Occurrence auszutauschen, wenn File vorliegt
        If oFileSystem.FileExists(sSepFilename) Then
            ' Alle Vorkommen der Komponenten austauschen, dazu die gesamte Liste der Vorkommen durchlaufen und wenn vorliegt, dann austauschen...
            'Call oAssDoc.BrowserPanes.ActivePane.Update
            For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                    Call oOcc.Replace(sSepFilename, False)
                    Debug.Print Tab(ItemTab); ">> Austauch " & Replace(sSepFilename, sBasePath, "..") & " gg. " & Replace(sVorhandenerFilename, sBasePath, "..")
                    ' Vermerken, dass jetzt der Austausch der oberen Baugruppen auch nötig ist
                    bAustauschNötig = True
                End If
            Next
        End If
    Next
    ' wenn Auswertung der unteren Baugruppen einen Austausch nötig macht, dann...
    If bAustauschNötig Then
        Debug.Print Tab(ItemTab); "Abschluss ExtractRefedDocs: Save+Close " & Replace(oAssDoc.FullFileName, sBasePath, "..")
        ' Baugruppe updaten sehr wichtig.
        Call oAssDoc.BrowserPanes.ActivePane.Update
        Call oAssDoc.Update
        ' Speichern und schließen
        Call oAssDoc.Save
        Call oAssDoc.Close
    Else
        sSepFilename = oAssDoc.FullFileName
        Debug.Print Tab(ItemTab); "Abschluss ExtractRefedDocs: Löschen " & Replace(sSepFilename, sBasePath, "..")
        Call oAssDoc.Close(True)
        Kill sSepFilename
    End If
   
    ItemTab = ItemTab - 4
   
    ExtractRefedDocs = bAustauschNötig
End Function

' gibt Basispath des Dokuments zurück
Private Function GetBasePath(ByVal odoc As Document) As String
    Dim oFileName As String
    oFileName = odoc.FullDocumentName
   
    GetBasePath = Left(oFileName, InStrRev(oFileName, "\") - 1)
End Function

' gibt Dateiname ohne Erweiterung zurück
Private Function GetDocumentName(ByVal odoc As Document) As String
    Dim oFileName As String
    oFileName = odoc.FullDocumentName
   
    Dim sName As String
    sName = Mid(oFileName, InStrRev(oFileName, "\") + 1)
   
    GetDocumentName = Left(sName, Len(sName) - 4)
End Function

' erzeugt den separierten SepFullFilename
Private Function CreateSepFilename(sBasePath As String, ByVal odoc As Document) As String
    CreateSepFilename = sBasePath & "\" & GetDocumentName(odoc) & "-separiert" & Right(odoc.FullFileName, 4)
End Function

---

Was mir noch Fragen aufgibt:
Die rekursive Funktion durchläuft alle Referenzen, öffnet die entsprechenden Unterbaugruppen bzw. Kinder, speichert diese unter dem neuen Separationsnamen und ruft sich dann selbst auf.

Bei diesem Speichern SCHEINT MANCHMAL in der Baugruppe EINE REFERRENZ auf die mit SaveAs erstelle Separation zurückzubleiben.

Dies ist verherend, denn das Bauteil ist dann irgendwie auf sich selbst referenziert.

Dies ist für mich nicht nachvollziehbar, aber verheerend. Denn so haben die realen iParts z.B. eine Referenz auf die separierten Bauteile.

Ist der SaveAs-Befehl da schwierig?

Vielleicht ist es das gleiche Problem:
Ich habe eine, ich nenne es mal "Anormalie" festgestellt:

Eine Baugruppe habe zwei Unterbaugruppen. Die erste Unterbaugruppe hat 2 Parts (also keine iParts). Die zweiter Unterbaugruppe ist eine iAssembly.

Beim Anwenden der Extraktion wird die erste Unterbaugruppe geöffnet und mit SaveAs unter dem Separationsnamen abgespeichert. Dabei scheint eine Referenz dazu hergestellt zu werden. Dies kann im Browser beobachtet werden, wenn man einen Haltepunkt auf Call oAssDoc.Update setzt. Dieses automatische Austauschen ist für mich nicht nachvollziehbar.

Was ist da zu ändern?

Viele Grüße schonmal,
Stefan

------------------
IV2008

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

---

Hallo

Das Verhalten habe ich auch beobachtet. Daher habe ich die Originale immer ohne Speichern geschlossen. Dabei flog der Fehler wieder raus. Bleiben die falschen Referenzen bei dir drin?
Ebenso hatte ich regelmäßig einen partout nicht aktualisierenden Teilebrowser. Der zeigte in Unterbaugruppen stur die original iParts statt der separierten Bauteile. Einmal Baugruppe schließen und wieder öffnen und es wurde korrekt dargestellt.
Die mit SaveAs erzeugten Kopien haben die gleiche interne Identnummer wie die Originale. Mein Verdacht wäre, das Inventor hier die Teile mit gleicher Identnummer verwechselt. Auch wenn sie in verschiedenen Verzeichnissen abgelegt sind. Genauere Infos könnte Autodesk liefern, aber ich glaube kaum das sie sich äußern würden.

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

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

---

Hallo Ralf, hallo hartnäckige vba'ler,

nach den Fehlschlägen kam ich gestern auf die (wie ich finde) erlösende Idee, die Prozesse zu entzerren.

Also 2 Durchläufe statt einem:
Im ersten Durchlauf nur öffnen und analysieren. Dabei eine Liste der zu separierenden Bauteilen/BGs mit Rekursionstiefe erstellen.

Im zweiten Durchlauf die Einträge der Liste gemäß Ihrer Rekursionstiefe abarbeiten. Tiefste Stufe zuerst.

Dann jeweils EIN Bauteil öffnen, speichern als und schließen.
Dann wieder öffnen, Tabelle weg und Referenzen tauschen und abschließendes Speichern.

Beim Programmieren der Analyse stellte ich dann fest, dass sich gelegentlich die iAssemblies nicht als solche erkannt werden
(oRefedAss.ComponentDefinition.IsiAssemblyMember = false, obwohl iAssemby vorliegt) ebenso wie
(oRefedPart.ComponentDefinition.IsiPartMember = false, obwohl iPart vorliegt).

Ebenso meldet die Zeile               
sMemberName = RefedPart.ComponentDefinition.iPartMember.row.MemberName dass die Objektvariable nicht festgelegt ist   

  WIE IST DAS MÖGLICH und vorallem... wie kann ich das wieder reparieren, denn selbst neue Modelle aus der gezippten Datei noch Neustarts ändern dies.

Bitte helft mir, mein Inventor scheint zu spinnen.

Viele verzweifelte Grüße,
Stefan

Code:

---

Dim sFilenamen(1 To 100) As String
Dim sMembernamen(1 To 100) As String
Dim bAustauschenNötig(1 To 100) As Boolean
Dim lRekTiefen(1 To 100) As Long
Dim lListenpos As Long

' Extrahiert aus der aktiven Baugruppe die iParts/iAssemblies raus
Sub ExtractAssFromiAss()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim oSourceDoc As AssemblyDocument
   
    Dim sBasePath As String
    Dim sVorhandenerFilename As String
    Dim lAustauschPos As Long
   
    Dim lRekTiefe As Long        ' Rekursionstiefe
    lRekTiefe = 0
    ' wenn Baugruppe aktiv, dann diese extrahieren
    If oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
        Set oSourceDoc = oApp.ActiveDocument
        ' Zielpfad und Zielname definieren
        sBasePath = GetBasePath(oSourceDoc) & "\Extraktion"
        sVorhandenerFilename = oSourceDoc.FullDocumentName
        Debug.Print "ExtractAssFromiAss: " & oSourceDoc.FullDocumentName
        ' Extrahiere aktive Assembly, wenn true zurück gegeben wurde, konnte Extraktion erfolgreich ausgeführt werden
        lListenpos = 1
        If ErstelleListeRefedDocs(oApp, oSourceDoc, sBasePath, lRekTiefe) Then
            For lAustauschPos = 1 To lListenpos
                Debug.Print Tab(4 * lRekTiefen(lAustauschPos)), IIf(bAustauschenNötig(lAustauschPos), "T", "F") & "  '" & sFilenamen(lAustauschPos) & "'  -  '" & sMembernamen(lAustauschPos) & "' Tiefe=" & lRekTiefen(lAustauschPos)
            Next
            'Set oSourceDoc = oApp.Documents.Open(sSepFilename)
            MsgBox "Extraktion erfolgreich abgeschlossen."
        Else
            Set oSourceDoc = oApp.Documents.Open(sVorhandenerFilename)
            MsgBox "Keine Extraktion möglich."
        End If
    Else
        MsgBox "Funktion nur in Baugruppen möglich", vbExclamation
    End If
End Sub

Private Function ErstelleListeRefedDocs(ByVal oApp As Inventor.Application, ByVal oAssDoc As AssemblyDocument, sBasePath As String, lRekTiefe As Long) As Boolean
    Dim oRefedDoc As Document
    Dim oRefedAss As AssemblyDocument
    Dim oRefedPart As PartDocument
   
    Dim oAssParent As AssemblyDocument          ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
             
    Dim oPartParent As PartDocument            ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow
   
    Dim oNormalesAssDoc As AssemblyDocument    ' für normale Assembly-Abwicklung
   
    Dim sVorhandenerFilename As String
    Dim sMemberName As String
   
    Dim oOcc As ComponentOccurrence

    Dim bAustauschNötig As Boolean, bNormaleAssAustauschen As Boolean
    bAustauschNötig = False
    Dim lAustauschPos As Long
   
    lRekTiefe = lRekTiefe + 1
    ' alle referenzierten Komponenten der Assemly durchlaufen
    For Each oRefedDoc In oAssDoc.ReferencedDocuments
        sVorhandenerFilename = oRefedDoc.FullDocumentName
        Debug.Print Tab(4 * lRekTiefe); ">> Komponente = " & Replace(sVorhandenerFilename, sBasePath, "..")

        'falls es eine Assembly ist, analysieren
        If oRefedDoc.DocumentType = kAssemblyDocumentObject Then
            Set oRefedAss = oRefedDoc
            ' wenn iAssembly, dann ...
            'MsgBox oRefedAss.FullDocumentName
            If (InStr(sVorhandenerFilename, "\iBaugruppe\") > 0) And (oRefedAss.ComponentDefinition.IsiAssemblyMember = False) Then
                Debug.Print Tab(4 * lRekTiefe); ">> FEHLER Detection = " & Replace(sVorhandenerFilename, sBasePath, "..")
            End If
            If oRefedAss.ComponentDefinition.IsiAssemblyMember Then
                ' Name des Kindes holen
                sMemberName = oRefedAss.ComponentDefinition.iAssemblyMember.row.MemberName
                ' Mutter öffnen
                Set oAssParent = oApp.Documents.Open(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName)
                ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                If Not oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMemberName Then
                    ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                    For Each oAssRow In oAssParent.ComponentDefinition.iAssemblyFactory.TableRows
                        If oAssRow.MemberName = sMemberName Then
                            oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                            Exit For
                        End If
                    Next
                End If
                ' Speichern der iAssembly unter neuem Namen
                lAustauschPos = AddInListe(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName, sMemberName, lRekTiefe)
                ' Kind der iassembly auswerten, schließt dabei das übergebene Dokument
                bAustauschNötig = bAustauschNötig Or ErstelleListeRefedDocs(oApp, oAssParent, sBasePath, lRekTiefe)
            Else
                ' "normale" iam, aber auch die könnte iParts/iAssemblies enthalten, also Extrahieren
                Set oRefedAss = oRefedDoc
                Set oNormalesAssDoc = oApp.Documents.Open(oRefedAss.FullFileName)
                lAustauschPos = AddInListe(sVorhandenerFilename, "", lRekTiefe)
                ' normale assembly auswerten, schließt dabei das übergebene Dokument
                bNormaleAssAustauschen = ErstelleListeRefedDocs(oApp, oNormalesAssDoc, sBasePath, lRekTiefe)
                ' wenn die normale Assembly keine iParts/iAss enthält, dann das Austauschen in der Liste löschen
                If Not bNormaleAssAustauschen Then bAustauschenNötig(lAustauschPos) = False
               
                bAustauschNötig = bAustauschNötig Or bNormaleAssAustauschen
            End If
         
       
        ElseIf oRefedDoc.DocumentType = kPartDocumentObject Then 'falls es ein iPart ist, dann...
            Set oRefedPart = oRefedDoc
            ' prüfe, ob iPart, dann analog extrahieren...
            If (InStr(sVorhandenerFilename, "\iBaugruppe\") > 0) And (oRefedPart.ComponentDefinition.IsiPartMember = False) Then
                Debug.Print Tab(4 * lRekTiefe); ">> FEHLER Detection = " & Replace(sVorhandenerFilename, sBasePath, "..")
            End If
            If oRefedPart.ComponentDefinition.IsiPartMember Then
                ' Name des Kindes holen
                sMemberName = oRefedPart.ComponentDefinition.iPartMember.row.MemberName
                Call AddInListe(oRefedPart.ComponentDefinition.iPartMember.ReferencedDocumentDescriptor.FullDocumentName, sMemberName, lRekTiefe)
                bAustauschNötig = True
            End If
        End If
    Next
    ' wenn Auswertung der unteren Baugruppen einen Austausch nötig macht, dann...
    Debug.Print Tab(4 * lRekTiefe); "Abschluss ErstelleListeRefedDocs: Close " & Replace(oAssDoc.FullFileName, sBasePath, "..")
    Call oAssDoc.Close(True)
   
    lRekTiefe = lRekTiefe - 1
 
    ErstelleListeRefedDocs = bAustauschNötig
End Function

' gibt Basispath des Dokuments zurück
Private Function GetBasePath(ByVal odoc As Document) As String
    Dim oFileName As String
    oFileName = odoc.FullDocumentName
   
    GetBasePath = Left(oFileName, InStrRev(oFileName, "\") - 1)
End Function

' gibt Dateiname ohne Erweiterung zurück
Private Function GetDocumentName(ByVal odoc As Document) As String
    Dim oFileName As String
    oFileName = odoc.FullDocumentName
   
    Dim sName As String
    sName = Mid(oFileName, InStrRev(oFileName, "\") + 1)
   
    GetDocumentName = Left(sName, Len(sName) - 4)
End Function

' erzeugt den separierten SepFullFilename
Private Function CreateSepFilename(sBasePath As String, ByVal odoc As Document) As String
    CreateSepFilename = sBasePath & "\" & GetDocumentName(odoc) & "-separiert" & Right(odoc.FullFileName, 4)
End Function
       

Private Function AddInListe(ByVal sNeuerName As String, ByVal sNeuerMembername As String, ByVal lNeueRekTiefe As Long) As Long
    sFilenamen(lListenpos) = sNeuerName
    sMembernamen(lListenpos) = sNeuerMembername
    lRekTiefen(lListenpos) = lNeueRekTiefe
    bAustauschenNötig(lListenpos) = True ' sicherheitshalber auf true setzen
    Debug.Print Tab(4 * lNeueRekTiefe); ">> AddInListe '" & sNeuerName & "' - '" & sNeuerMembername; "' - Tiefe=" & lNeueRekTiefe
    AddInListe = lListenpos
    lListenpos = lListenpos + 1
    sFilenamen(lListenpos) = "" ' nächsten schonmal löschen
End Function

---

------------------
IV2008

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

---

Browser.pdf

Hallo Ralf, hallo Unterstützer des Projekts,

lange, lange Versuchsreihen haben zu dem funktionierenden Ergebnis geführt. Ich mußte erkennen, dass alles einzeln und separat gemacht werden mußte, da Inventor sonst irgendeine Referenz mitspeichert.

Also: Es läuft für iAssemlies mit iParts inkl. normale Parts und Assemblies, jedoch irgendwie nicht für Schweißkonstruktionen.

Ich vermute, da braucht es ein anderes anderes Objekt, um die Komponenten auszutauschen.

Bitte gebt mir dafür Tipps, wie Schweißkonstrktionen zu erkennen sind und was zu ändern ist, damit die Bauteile auch hier ausgetauscht werden können.

Zum zweiten : Leider ist im Teilebrowser die Darstellung nach der Extraction anders aus. Teilweise ist der iPartname (SRA) angezeigt, obwohl das Bauteil effektiv das extrahierte Kind ist, andererseits fehlen die Elemente des Parts (Extraktionen und Drehungen)-Hmmm

Danke für alle Tipps dazu und schon mal den Code, für den, der ihn auch mal brauchen will, um z.B. Bemaßungen etc abzurufen und die Ladegeschwindigkeiten zu erhöhen (da die iParts/iAss weg sind)

Gruß Stefan

Code:

---

Const conSeparation = "-separiert"                      ' temporäre Erweiterung des Dateinamens, die sonst nicht in Dateinamen verwendet wird
Const conOriginalnamen = True                          ' bei true wird im Anschluß an die Separation noch gg. die Originalnamen getauscht

Const maxFeldgrösse = 100                              ' globale Arraygröße
Dim bAustauschenNötig(1 To maxFeldgrösse) As Boolean    ' Wenn Baugruppe auzutauschen ist, dann true
Dim bLöschenNötig(1 To maxFeldgrösse) As Boolean        ' Merker, welche separierten Files nachträglich zu löschen sind
Dim sFilenamen(1 To maxFeldgrösse) As String            ' Name für Filenames (der Eltern/ der zu löschenden sep. Files)
Dim sMembernamen(1 To maxFeldgrösse) As String          ' Name der Kinder
Dim lListenpos As Long                                  ' globaler Index zum Beschrieben der Liste

Option Explicit

' Extrahiert aus der aktiven Baugruppe die iParts/iAssemblies raus
Sub ExtractAssFromiAss()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim oSourceAssDoc As AssemblyDocument
   
    Dim sBasePath As String, sVorhandenerFilename As String, sSepFilename As String

    Dim lAustauschPos As Long      ' Merker für Position der Start-Baugruppe in der Liste
       
    ' wenn Baugruppe aktiv, dann diese extrahieren
    If oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
        Set oSourceAssDoc = oApp.ActiveDocument
        ' Zielpfad und Zielname definieren
        sVorhandenerFilename = oSourceAssDoc.FullDocumentName
        sSepFilename = HoleNeuenBGNamen("Neuer Name für Extraktion")
        If sSepFilename <> "" Then
            sBasePath = Left(sSepFilename, InStrRev(sSepFilename, "\") - 1)
            ' aktuelle Start-Baugruppe separiert abspeichern
            Call oSourceAssDoc.SaveAs(sSepFilename, True)
            ' globale Liste löschen
            ClearInListe
            ' Start-assembly in Liste schreiben
            lAustauschPos = AddInListe(sSepFilename, "")
            ' (i)assembly auswerten, Liste erstellen, schließt dabei das übergebene Dokument, gibt zurück, ob das Bauteil ausgetauscht werden kann
            bAustauschenNötig(lAustauschPos) = ErstelleListeRefedDocs(oApp, oSourceAssDoc)
            ' wenn Auswertung ergeben hat, dass Austausch nötig, dann...
            If bAustauschenNötig(lAustauschPos) Then
                ' iste rückwärts abarbeiten um separat zu speichern und anschließend zu ersetzen
                Call ErstelleSeparation(sBasePath)
                ' wenn Ausführung mit Originalnamen gewünscht,...
                If conOriginalnamen Then
                    ÄndereInOriginalnamen
                End If
                MsgBox "Extraktion erfolgreich abgeschlossen."
            Else
                MsgBox "Keine Extraktion nötig."
            End If
            Set oSourceAssDoc = oApp.Documents.Open(sSepFilename)
        End If
    Else
        MsgBox "Funktion nur in Baugruppen möglich", vbExclamation
    End If
End Sub

' erstellt globale Liste der referenzierten Bauteile/Baugruppen inkl. des boolschen Wertes, ob letztendlich ein Austausch nötig ist (da in untergeordneten Baugruppen iParts/iAssemblies vorliegen)
Private Function ErstelleListeRefedDocs(ByVal oApp As Inventor.Application, ByVal oAssDoc As AssemblyDocument) As Boolean
    Dim oRefedDoc As Document
    Dim oRefedAss As AssemblyDocument
    Dim oRefedPart As PartDocument
   
    Dim oAssParent As AssemblyDocument          ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
             
    Dim oPartParent As PartDocument            ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow

    Dim oNormalesAssDoc As AssemblyDocument    ' für normale Assembly-Abwicklung
   
    Dim sVorhandenerFilename As String
    Dim sMemberName As String
   
    Dim oOcc As ComponentOccurrence

    Dim bAustauschNötig As Boolean, bNormaleAssAustauschen As Boolean
    bAustauschNötig = oAssDoc.ComponentDefinition.IsiAssemblyFactory    ' wenn BG iAssembly ist, dann sowieso Austausch nötig, sonst erstmal Annahme, dass unnötig
    Dim lAustauschPos As Long                                          ' Merker für Position der Baugruppe in der Liste
   
    ' alle referenzierten Komponenten der Assemly durchlaufen
    For Each oRefedDoc In oAssDoc.ReferencedDocuments
        sVorhandenerFilename = oRefedDoc.FullDocumentName
        'falls es eine Assembly ist, analysieren
        If oRefedDoc.DocumentType = kAssemblyDocumentObject Then
            Set oRefedAss = oRefedDoc
            ' wenn iAssembly, dann ...
            'MsgBox oRefedAss.FullDocumentName
            If oRefedAss.ComponentDefinition.IsiAssemblyMember Then
                ' Name des Kindes holen
                sMemberName = oRefedAss.ComponentDefinition.iAssemblyMember.Row.MemberName
                ' Mutter öffnen
                Set oAssParent = oApp.Documents.Open(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName)
                ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                If Not oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMemberName Then
                    ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                    For Each oAssRow In oAssParent.ComponentDefinition.iAssemblyFactory.TableRows
                        If oAssRow.MemberName = sMemberName Then
                            oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                            Exit For
                        End If
                    Next
                End If
                ' Speichern der iAssembly unter neuem Namen
                lAustauschPos = AddInListe(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName, sMemberName)
                ' Kind der iassembly auswerten, schließt dabei das übergebene Dokument
                bAustauschNötig = bAustauschNötig Or ErstelleListeRefedDocs(oApp, oAssParent)
            ElseIf Not oRefedAss.ComponentDefinition.IsiAssemblyFactory Then  ' detected as assembly
                ' "normale" iam, aber auch die könnte iParts/iAssemblies enthalten, also Extrahieren
                Set oRefedAss = oRefedDoc
                Set oNormalesAssDoc = oApp.Documents.Open(oRefedAss.FullFileName)
                lAustauschPos = AddInListe(sVorhandenerFilename, "")
                ' normale assembly auswerten, schließt dabei das übergebene Dokument
                bNormaleAssAustauschen = ErstelleListeRefedDocs(oApp, oNormalesAssDoc)
                ' wenn die normale Assembly keine iParts/iAss enthält, dann das Austauschen in der Liste löschen
                If Not bNormaleAssAustauschen Then bAustauschenNötig(lAustauschPos) = False
               
                bAustauschNötig = bAustauschNötig Or bNormaleAssAustauschen
            End If
         
       
        ElseIf oRefedDoc.DocumentType = kPartDocumentObject Then 'falls es ein iPart ist, dann...
            Set oRefedPart = oRefedDoc
            ' prüfe, ob iPart, dann analog extrahieren...
            If oRefedPart.ComponentDefinition.IsiPartMember Then
                ' Name des Kindes holen
                sMemberName = oRefedPart.ComponentDefinition.iPartMember.Row.MemberName
                Call AddInListe(oRefedPart.ComponentDefinition.iPartMember.ReferencedDocumentDescriptor.FullDocumentName, sMemberName)
                bAustauschNötig = True
            End If
        End If
    Next
    ' wenn Auswertung der unteren Baugruppen einen Austausch nötig macht, dann...
    Call oAssDoc.Close(True)
   
    ErstelleListeRefedDocs = bAustauschNötig
End Function

' Erstellte globale Liste wird rückwärts durchlaufen und gespeicherte Bauteile/-gruppen separiert und im 2. Schritt ersetzen
Private Sub ErstelleSeparation(sBasePath As String)
    Dim lInListePos As Long
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim sSepFilename As String
    Dim sVorhandenerFilename As String
    Dim sMemberName As String
   
    Dim oFileSystem As Object
    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    Dim oOcc As ComponentOccurrence
   
    Dim oRefedAss As AssemblyDocument
    Dim oAssDoc As AssemblyDocument ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
             
    Dim oPartDoc As PartDocument ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow

    Dim oSourceDoc As Document
   
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen unter separierten Namen speichern
    For lInListePos = lListenpos - 1 To 2 Step -1 ' bis zum zweitersten, denn das erste File ist schon gespeichert worden.
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            Set oSourceDoc = oApp.Documents.Open(sFilenamen(lInListePos))
            sMemberName = sMembernamen(lInListePos)
            If sMemberName <> "" Then ' wenn iPart/iAssembly vorliegt
                sSepFilename = sBasePath & "\" & sMemberName & conSeparation & Right(oSourceDoc.FullFileName, 4)
            Else
                sSepFilename = CreateSepFilename(sBasePath, oSourceDoc)
            End If
            sFilenamen(lInListePos) = sSepFilename
            Call oSourceDoc.SaveAs(sSepFilename, True)
            Call oSourceDoc.Close(True)
        End If
    Next
   
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen gegen die separierten Bauteile/-gruppen ersetzen
    For lInListePos = lListenpos - 1 To 1 Step -1
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            'falls es eine Assembly ist, analysieren
            If LCase(Right(sFilenamen(lInListePos), 3) = "iam") Then
                ' iam öffnen
                Set oAssDoc = oApp.Documents.Open(sFilenamen(lInListePos))
                ' wenn iAssembly, dann ist membername gesetzt ...
                If sMembernamen(lInListePos) <> "" Then
                    ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                    If Not (oAssDoc.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMembernamen(lInListePos)) Then
                        ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                        For Each oAssRow In oAssDoc.ComponentDefinition.iAssemblyFactory.TableRows
                            If oAssRow.MemberName = sMembernamen(lInListePos) Then
                                oAssDoc.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                                Exit For
                            End If
                        Next
                    End If
                End If
                ' Tabelle löschen wenn iAss-Factory angelegt ist
                If oAssDoc.ComponentDefinition.IsiAssemblyFactory Then Call oAssDoc.ComponentDefinition.iAssemblyFactory.Delete
                ' alle referenzierten Komponenten durchlaufen...
                For Each oSourceDoc In oAssDoc.ReferencedDocuments
                    sVorhandenerFilename = oSourceDoc.FullDocumentName ' vorhandener Namen der Komponenten zum Austausch merken
                    sSepFilename = sBasePath & "\" & GetDocumentName(oSourceDoc) & conSeparation & Right(oSourceDoc.FullFileName, 4)
                   
                    If oFileSystem.FileExists(sSepFilename) Then ' Occurrence auszutauschen, wenn File vorliegt
                        For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                            If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                                Call oOcc.Replace(sSepFilename, False)
                            End If
                        Next
                    End If
                Next
               
                Call oAssDoc.BrowserPanes.ActivePane.Update
                Call oAssDoc.Update
                ' speichern und schließen
                Call oAssDoc.Save
                'If InStr(oAssDoc.FullFileName, conSeparation) > 0 Then Call oAssDoc.SaveAs(Replace(oAssDoc.FullFileName, conSeparation, ""), True)
                Call oAssDoc.Close(True)
            ElseIf LCase(Right(sFilenamen(lInListePos), 3) = "ipt") Then 'falls es ein iPart ist, dann...
                Set oPartDoc = oApp.Documents.Open(sFilenamen(lInListePos))
                ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                If Not (oPartDoc.ComponentDefinition.iPartFactory.DefaultRow.MemberName = sMembernamen(lInListePos)) Then
                    ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                    For Each oPartRow In oPartDoc.ComponentDefinition.iPartFactory.TableRows
                        If oPartRow.MemberName = sMembernamen(lInListePos) Then
                            oPartDoc.ComponentDefinition.iPartFactory.DefaultRow = oPartRow
                            Exit For
                        End If
                    Next
                End If
                ' Tabelle löschen
                Call oPartDoc.ComponentDefinition.iPartFactory.Delete
                ' Speichern die zweite und schließen
                Call oPartDoc.Update
                Call oPartDoc.Save
                Call oPartDoc.Close(True)
            End If
        End If
    Next
End Sub

' ggf abschließende Operation, die Originalnamen statt der separierten zu tauschen.
Private Sub ÄndereInOriginalnamen()
    Dim lInListePos As Long
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim sSepFilename As String
    Dim sVorhandenerFilename As String
   
    Dim oFileSystem As Object
    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    Dim oOcc As ComponentOccurrence
   
    Dim oAssDoc As AssemblyDocument ' für iAssembly-Abwicklung

    Dim oSourceDoc As Document
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen unter Namen OHNE Separation speichern
    For lInListePos = lListenpos - 1 To 2 Step -1 ' bis zum zweitersten, denn das erste File ist schon gespeichert worden.
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            Set oSourceDoc = oApp.Documents.Open(sFilenamen(lInListePos))
            sSepFilename = Replace(sFilenamen(lInListePos), conSeparation, "")
            Call oSourceDoc.SaveAs(sSepFilename, True)
            Call oSourceDoc.Close(True)
        End If
    Next
   
    ' Liste rückwärts durchlaufen und separierten Bauteile/Baugruppen gegen die Bauteile/-gruppen mit Originalnamen ersetzen
    For lInListePos = lListenpos - 1 To 1 Step -1
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            'falls es eine Assembly ist, analysieren
            If LCase(Right(sFilenamen(lInListePos), 3) = "iam") Then
                ' iam öffnen
                Set oAssDoc = oApp.Documents.Open(Replace(sFilenamen(lInListePos), conSeparation, ""))
                ' wenn iAssembly, dann ist membername gesetzt ...
                For Each oSourceDoc In oAssDoc.ReferencedDocuments
                    sVorhandenerFilename = oSourceDoc.FullDocumentName ' vorhandener Namen der Komponenten zum Austausch merken
                    If InStr(sVorhandenerFilename, conSeparation) > 0 Then ' wenn als separiertes Bauteil gespeichert
                        sSepFilename = Replace(sVorhandenerFilename, conSeparation, "")
                        If oFileSystem.FileExists(sSepFilename) Then ' Occurrence auszutauschen, wenn File ohne -separiert vorliegt
                            For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                                If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                                    Call oOcc.Replace(sSepFilename, False)
                                    Call MarkFilenameInListe(sVorhandenerFilename)
                                End If
                            Next
                        End If
                    End If
                Next
               
                Call oAssDoc.BrowserPanes.ActivePane.Update
                Call oAssDoc.Update
                ' speichern und schließen
                Call oAssDoc.Save
                Call oAssDoc.Close(True)
            End If
        End If
    Next
   
    ' Liste durchlaufen und zum Löschen markierte Bauteile/Baugruppen löschen
    For lInListePos = 2 To lListenpos - 1
        If bLöschenNötig(lInListePos) Then Kill sFilenamen(lInListePos)
    Next
End Sub

' gibt Dateiname ohne Erweiterung zurück
Private Function GetDocumentName(ByVal oDoc As Document) As String
    Dim oFileName As String
    oFileName = oDoc.FullDocumentName
   
    Dim sName As String
    sName = Mid(oFileName, InStrRev(oFileName, "\") + 1)
   
    GetDocumentName = Left(sName, Len(sName) - 4)
End Function

' erzeugt den separierten SepFullFilename
Private Function CreateSepFilename(sBasePath As String, ByVal oDoc As Document) As String
    CreateSepFilename = sBasePath & "\" & GetDocumentName(oDoc) & conSeparation & Right(oDoc.FullFileName, 4)
End Function
       

' löscht globale Liste der rekursiv erfassten Bauteile/Baugruppen
Private Sub ClearInListe()
    Dim lL As Long
   
    lListenpos = 1
    For lL = 1 To maxFeldgrösse - 1
        Call AddInListe("", "")
    Next
    lListenpos = 1
End Sub

' trägt die übergebenen File- und Membernamen in die globale Liste der rekursiv erfassten Bauteile/Baugruppen
Private Function AddInListe(ByVal sNeuerName As String, ByVal sNeuerMembername As String) As Long
    sFilenamen(lListenpos) = sNeuerName
    sMembernamen(lListenpos) = sNeuerMembername
    bAustauschenNötig(lListenpos) = (sNeuerName <> "") ' sicherheitshalber auf true setzen, wenn Name gesetzt, sonst false
    bLöschenNötig(lListenpos) = False
   
    AddInListe = lListenpos
   
    If lListenpos < maxFeldgrösse Then
        lListenpos = lListenpos + 1
    Else
        MsgBox "maxFeldgrösse=" & maxFeldgrösse & " zu gering.", vbExclamation
    End If
End Function

' marks in global list the member which has to be killed
Private Sub MarkFilenameInListe(ByVal sKillName As String)
    Dim lL As Long
    Dim sSearchMembername As String
   
    sSearchMembername = Mid(sKillName, InStrRev(sKillName, "\") + 1)
    sSearchMembername = Replace(sSearchMembername, conSeparation, "")
    For lL = 1 To maxFeldgrösse - 1
        If sFilenamen(lL) <> "" Then
            If sMembernamen(lL) & Right(sFilenamen(lL), 4) = sSearchMembername Or _
                Mid(sFilenamen(lL), InStrRev(sFilenamen(lL), "\")) = Mid(sKillName, InStrRev(sKillName, "\")) Then
                bLöschenNötig(lL) = True
                sFilenamen(lL) = sKillName
                Exit For
            End If
        End If
    Next
End Sub

' Funtion holt sich Baugruppennamen vom Benutzer
Public Function HoleNeuenBGNamen(sFDText As String) As String
    Dim sPfad As String
   
    ' Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)
 
    ' Define the filter to select part and assembly files or any file.
    oFileDlg.Filter = "Inventor Files (*.iam)|*.iam|All Files (*.*)|*.*"
    ' Define the part and assembly files filter to be the default filter.
    oFileDlg.FilterIndex = 1
    ' Set the title for the dialog.
    oFileDlg.DialogTitle = sFDText
 
    ' Set the initial directory that will be displayed in the dialog.
    sPfad = ThisApplication.ActiveDocument.FullFileName
    sPfad = Left(sPfad, InStrRev(sPfad, "\"))
    oFileDlg.InitialDirectory = sPfad
  ' Show the open dialog.  The same procedure is also used for the Save dialog.
    oFileDlg.ShowSave
 
    HoleNeuenBGNamen = oFileDlg.FileName
End Function

---

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

---

Hallo

Mit Schweißkonstruktionen hab ich mich noch nie wirklich befaßt.
Stimmt der Teilebrowser auch nach einem Schließen und wieder Öffnen der Baugruppen noch nicht oder nur direkt nach dem Durchlauf? Ich kenn das Verhalten nur direkt nach der Extraktion.
Was heißt die Elemente fehlen? Zeigt das Bauteil nur eine gelöste Referenz auf ein anderes Bauteil oder einen Volumenkörper? Hast du statt der Factory versehentlich ein Member zum Extrahieren erwischt?

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

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

---

Hallo Ralf,

lt. meiner (bescheidenen) Rechersche in der Hilfe, benötige ich die WeldmentCompondDefinition, die fast genau so aufgebaut ist wie die von Dir verwendete CompondDefinition.

Was ich nicht herausbekomme ist, wie unterscheide ich, ob ich die CompondDefinition einer normalen Assembly oder die WeldmentCompondDefinition einer Schweißkonstruktion verwenden muß, um die Komponenten auszutauschen.

Die 'oAssDoc.ComponentDefinition.Occurrences' sind beim Abarbeiten  einer Schweißkonstruktion als Object nicht definiert.

Code:

---

                For Each oSourceDoc In oAssDoc.ReferencedDocuments
                    sVorhandenerFilename = oSourceDoc.FullDocumentName ' vorhandener Namen der Komponenten zum Austausch merken
                    sSepFilename = sBasePath & "\" & GetDocumentName(oSourceDoc) & conSeparation & Right(oSourceDoc.FullFileName, 4)
                 
                    If oFileSystem.FileExists(sSepFilename) Then ' Occurrence auszutauschen, wenn File vorliegt
                        For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                            If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                                Call oOcc.Replace(sSepFilename, False)
                            End If
                        Next
                    End If
                Next

---

Ansonsten hast Du recht, die Anzeige simmt nach dem Neuöffnen soweit wieder.

Ich hatte in dem obigen Beitrag die 'Browser.pdf' hochgeladen, die den Teielbrowser zeigt: Dort ist zu sehen, dass SRA (iPart-Muttername) aber auch FUEBGR7800450-C380 der Name eines Kindes ist.

Diese uneinheitliche Bezeichnung bleibt. Es scheint mir, als müsse den Bauteilname explizit gesetzt werden. Es ist der Name, der beim Speichern sich nach dem Dateinamen richtet. Nur wie?

Aber am meisten würde mir die Unterscheidung Schweißkonstruktion/normale Assemby helfen.... Danke für jede Idee dazu,

Stefan

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

---

Hallo

Ich wollte nur mal zitieren was Autodesk dazu sagt:

Zitat:

---

Well, unfortunately 2008 sounds like an old release already, the development team does not support that many releases back.

---

Kommentar spar ich mir.  

Untersuche den Typ der ComponentDefinition.
normale Baugruppe --> ComponentDefinition.Type = kAssemblyComponentDefinition
Schweißbaugruppe  --> ComponentDefinition.Type = kWeldmentComponentDefinition

Der Browsername kann aus dem iPropertie Bauteilnummer kommen, wenn das beim ersten Speichern bereits gefüllt ist. Es gibt ein Tool zum Zuürcksetzen der BrowserNodenamen. In 2008 gab's das glaub ich höchstens im SubscriptionPack. Ich schau mal morgen nach.

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

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

---

ModelleSchweisk.zip

Hallo Ralf,

leider ist kWeldmentComponentDefinition bei mir nicht als "Schlüsselwort" definiert.

Aber

Code:

---

TypeOf oOcc.Definition Is WeldsComponentDefinition

---

ergibt eine mögliche Prüfung. Soweit bin ich jetzt.

Und da nette Modelle das Testen erleichtern habe ich eine Schweißkonstruktion mit kundenspezifischem Deckel erstellt.

Danke weiterhin für Dein Engagement 

Viele Grüße,
Stefan

------------------
IV2008

[Diese Nachricht wurde von st.w am 26. Mrz. 2013 editiert.]

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

---

Hallo zusammen,

folgende Zusammenfassung will ich geben, um das Ergebnis nicht zu verwässern:

Die Extraktion klappt, bei iAssemblies/iParts und Assemblies mit diesen Elementen. Jetzt sogar mit richtigem, ergänztem Displaynamen.

Wenn eine weiterhin richtige Anordnung der Bauteile nach der Extraktion gewünscht ist, ist dies über iMates der Bauteile/Baugruppen machbar, die die Teile bei dem Austauschen wieder sicher zusammenfügen. 

Alle anderen Abhängigkeiten, Nachbearbeitungen und Schweißnähte "fliegen" weg, da die Definition der notwendigen Flächen/Konturen entzogen werden, bzw beim Austauschen die abhängig gemachten Konturen/Flächen (kurzzeitig) weg sind. Die Nacharbeitsskizzen bleiben jedoch erhalten und können nach der Extraction genutzt werden.

Daraus folgt: Die Extraktion ist sehr gut nutzbar, jedoch muss NACH der Extraction (erneut) geschweißt, nachbarbeitet und individuelle Abhängigkeiten nachbearbeitet werden.      

Trotzdem überwiegt in meinem Fall der Vorteil, ein individuelles Bauteil vorliegen zu haben, das noch speziell nachgearbeitet werden kann und bei dem ich bei der Zeichnungserstellung die Bemaßungen abrufen kann. Die Ladezeit ist aber um Faktoren schneller und die Aktualisierungen, die aufgrund von (zukünftigen) Änderungen der iParts herrühren sind unterbunden.

Soweit die Freigabeinfo... - DANK an Dich Ralf!

So long,
Stefan

Code:

---

Const conSeparation = "-separiert"                      ' temporäre Erweiterung des Dateinamens, die sonst nicht in Dateinamen verwendet wird
Const maxFeldgrösse = 100                              ' globale Arraygröße
Dim bAustauschenNötig(1 To maxFeldgrösse) As Boolean    ' Wenn Baugruppe auzutauschen ist, dann true
Dim bLöschenNötig(1 To maxFeldgrösse) As Boolean        ' Merker, welche separierten Files nachträglich zu löschen sind
Dim sFilenamen(1 To maxFeldgrösse) As String            ' Name für Filenames (der Eltern/ der zu löschenden sep. Files)
Dim sMembernamen(1 To maxFeldgrösse) As String          ' Name der Kinder
Dim lListenpos As Long                                  ' globaler Index zum Beschrieben der Liste

' Extrahiert aus der aktiven Baugruppe/ aktivem iPart die Parts/Assemblies raus
Public Sub iExtract()
    Dim oapp As Inventor.Application
    Set oapp = ThisApplication
 
    Dim oSourceAssDoc As AssemblyDocument
    Dim oPartDoc As PartDocument ' für iPart-Abwicklung

    Dim sBasePath As String, sVorhandenerFilename As String, sSepFilename As String, sMembername As String

    Dim lAustauschPos As Long      ' Merker für Position der Start-Baugruppe in der Liste
     
    ' wenn Baugruppe aktiv, dann diese extrahieren
    If oapp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
        Set oSourceAssDoc = oapp.ActiveDocument
        ' Zielpfad und Zielname definieren
        If oSourceAssDoc.ComponentDefinition.IsiAssemblyFactory = True Then
            sVorhandenerFilename = oSourceAssDoc.ComponentDefinition.iAssemblyFactory.DefaultRow.DocumentName
        Else
            sVorhandenerFilename = Mid(oSourceAssDoc.FullDocumentName, InStrRev(oSourceAssDoc.FullDocumentName, "\") + 1)
        End If
        sSepFilename = HoleNeuenBGNamen("Extraktion speichern unter...", sVorhandenerFilename)
        If sSepFilename <> "" Then
            sBasePath = Left(sSepFilename, InStrRev(sSepFilename, "\") - 1)
            ' aktuelle Start-Baugruppe separiert abspeichern
            Call oSourceAssDoc.SaveAs(sSepFilename, True)
            ' globale Liste löschen
            ClearInListe
            ' Start-assembly in Liste schreiben, dazu ggf. Membername separieren
            If oSourceAssDoc.ComponentDefinition.IsiAssemblyFactory = True Then
                sMembername = Mid(sSepFilename, InStrRev(sSepFilename, "\") + 1)
                sMembername = Left(sMembername, Len(sMembername) - 4)
            Else
                sMembername = ""
            End If
            lAustauschPos = AddInListe(sSepFilename, sMembername)
            ' (i)assembly auswerten, Liste erstellen, schließt dabei das übergebene Dokument, gibt zurück, ob das Bauteil ausgetauscht werden kann
            bAustauschenNötig(lAustauschPos) = ErstelleListeRefedDocs(oapp, oSourceAssDoc)
            ' wenn Auswertung ergeben hat, dass Austausch nötig, dann...
            If bAustauschenNötig(lAustauschPos) Then
                ' Liste rückwärts abarbeiten um separat zu speichern und anschließend zu ersetzen
                Call ErstelleSeparation(sBasePath)
                ' ändern in Originalnamen
                ÄndereInOriginalnamen
                Call LöscheOldVersions(sBasePath)
                MsgBox "Extraktion erfolgreich abgeschlossen." & Chr(10) & Chr(10) & "Extrahierte Baugruppe wird geöffnet."
            Else
                MsgBox "Keine Extraktion nötig, daher nur separat gespeichert." & Chr(10) & Chr(10) & "Separat gespeicherte Baugruppe wird geöffnet."
            End If
            Set oSourceAssDoc = oapp.Documents.Open(sSepFilename)
        End If
    ElseIf oapp.ActiveDocument.DocumentType = kPartDocumentObject Then
        If oapp.ActiveDocument.ComponentDefinition.IsiPartFactory = True Then
            sVorhandenerFilename = oapp.ActiveDocument.ComponentDefinition.iPartFactory.DefaultRow.PartName
            sSepFilename = HoleNeuenBGNamen("Extraktion speichern unter...", sVorhandenerFilename)
            If sSepFilename <> "" Then
                sBasePath = Left(sSepFilename, InStrRev(sSepFilename, "\") - 1)
                ' aktuelle Start-Baugruppe separiert abspeichern
                Call oapp.ActiveDocument.SaveAs(sSepFilename, True)
                Call oapp.ActiveDocument.Close(True)
               
                Set oPartDoc = oapp.Documents.Open(sSepFilename)
                oPartDoc.DisplayName = sVorhandenerFilename
                ' Tabelle löschen
                Call oPartDoc.ComponentDefinition.iPartFactory.Delete
                ' Speichern die zweite und schließen
                Call oPartDoc.Update
                Call oPartDoc.Save
                Call oPartDoc.Close(True)
                MsgBox "Extraktion des iParts erfolgreich abgeschlossen." & Chr(10) & Chr(10) & "Extrahiertes Bauteil wird geöffnet."
                Set oPartDoc = oapp.Documents.Open(sSepFilename)
            End If
        Else
            MsgBox "Keine Extraktion nötig."
        End If
    Else
        MsgBox "Funktion nur in Bauteilen/Baugruppen möglich", vbExclamation
    End If
End Sub

' erstellt globale Liste der referenzierten Bauteile/Baugruppen inkl. des boolschen Wertes, ob letztendlich ein Austausch nötig ist (da in untergeordneten Baugruppen iParts/iAssemblies vorliegen)
Private Function ErstelleListeRefedDocs(ByVal oapp As Inventor.Application, ByVal oAssDoc As AssemblyDocument) As Boolean
    Dim oRefedDoc As Document
    Dim oRefedAss As AssemblyDocument
    Dim oRefedPart As PartDocument
 
    Dim oAssParent As AssemblyDocument          ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
           
    Dim oPartParent As PartDocument            ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow

    Dim oNormalesAssDoc As AssemblyDocument    ' für normale Assembly-Abwicklung
 
    Dim sVorhandenerFilename As String
    Dim sMembername As String
 
    Dim oOcc As ComponentOccurrence

    Dim bAustauschNötig As Boolean, bNormaleAssAustauschen As Boolean
    bAustauschNötig = oAssDoc.ComponentDefinition.IsiAssemblyFactory    ' wenn BG iAssembly ist, dann sowieso Austausch nötig, sonst erstmal Annahme, dass unnötig
    Dim lAustauschPos As Long                                          ' Merker für Position der Baugruppe in der Liste
 
    ' alle referenzierten Komponenten der Assemly durchlaufen
    For Each oRefedDoc In oAssDoc.ReferencedDocuments
        sVorhandenerFilename = oRefedDoc.FullDocumentName
        'falls es eine Assembly ist, analysieren
        If oRefedDoc.DocumentType = kAssemblyDocumentObject Then
            Set oRefedAss = oRefedDoc
            ' wenn iAssembly, dann ...
            'MsgBox oRefedAss.FullDocumentName
            If oRefedAss.ComponentDefinition.IsiAssemblyMember Then
                ' Name des Kindes holen
                sMembername = oRefedAss.ComponentDefinition.iAssemblyMember.row.MemberName
                ' Mutter öffnen
                Set oAssParent = oapp.Documents.Open(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName)
                ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                If Not oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMembername Then
                    ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                    For Each oAssRow In oAssParent.ComponentDefinition.iAssemblyFactory.TableRows
                        If oAssRow.MemberName = sMembername Then
                            oAssParent.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                            Exit For
                        End If
                    Next
                End If
                ' Speichern der iAssembly unter neuem Namen
                lAustauschPos = AddInListe(oRefedAss.ComponentDefinition.iAssemblyMember.ReferencedDocumentDescriptor.FullDocumentName, sMembername)
                ' Kind der iassembly auswerten, schließt dabei das übergebene Dokument
                bAustauschNötig = bAustauschNötig Or ErstelleListeRefedDocs(oapp, oAssParent)
            ElseIf Not oRefedAss.ComponentDefinition.IsiAssemblyFactory Then  ' detected as assembly
                ' "normale" iam, aber auch die könnte iParts/iAssemblies enthalten, also Extrahieren
                Set oRefedAss = oRefedDoc
                Set oNormalesAssDoc = oapp.Documents.Open(oRefedAss.FullFileName)
                lAustauschPos = AddInListe(sVorhandenerFilename, "")
                ' normale assembly auswerten, schließt dabei das übergebene Dokument
                bNormaleAssAustauschen = ErstelleListeRefedDocs(oapp, oNormalesAssDoc)
                ' wenn die normale Assembly keine iParts/iAss enthält, dann das Austauschen in der Liste löschen
                If Not bNormaleAssAustauschen Then bAustauschenNötig(lAustauschPos) = False
             
                bAustauschNötig = bAustauschNötig Or bNormaleAssAustauschen
            End If
       
     
        ElseIf oRefedDoc.DocumentType = kPartDocumentObject Then 'falls es ein iPart ist, dann...
            Set oRefedPart = oRefedDoc
            ' prüfe, ob iPart, dann analog extrahieren...
            If oRefedPart.ComponentDefinition.IsiPartMember Then
                ' Name des Kindes holen
                sMembername = oRefedPart.ComponentDefinition.iPartMember.row.MemberName
                Call AddInListe(oRefedPart.ComponentDefinition.iPartMember.ReferencedDocumentDescriptor.FullDocumentName, sMembername)
                bAustauschNötig = True
            End If
        End If
    Next
    ' wenn Auswertung der unteren Baugruppen einen Austausch nötig macht, dann...
    Call oAssDoc.Close(True)
 
    ErstelleListeRefedDocs = bAustauschNötig
End Function

' Erstellte globale Liste wird rückwärts durchlaufen und gespeicherte Bauteile/-gruppen separiert und im 2. Schritt ersetzen
Private Sub ErstelleSeparation(sBasePath As String)
    Dim lInListePos As Long
    Dim oapp As Inventor.Application
    Set oapp = ThisApplication
 
    Dim sSepFilename As String
    Dim sVorhandenerFilename As String
    Dim sMembername As String
 
    Dim oFileSystem As Object
    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    Dim oOcc As ComponentOccurrence
 
    Dim oRefedAss As AssemblyDocument
    Dim oAssDoc As AssemblyDocument ' für iAssembly-Abwicklung
    Dim oAssRow As iAssemblyTableRow
           
    Dim oPartDoc As PartDocument ' für iPart-Abwicklung
    Dim oPartRow As iPartTableRow
    Dim oSourceDoc As Document
 
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen unter separierten Namen speichern
    For lInListePos = lListenpos - 1 To 1 Step -1 ' bis zum zweitersten, denn das erste File ist schon gespeichert worden.
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            Set oSourceDoc = oapp.Documents.Open(sFilenamen(lInListePos))
            sMembername = sMembernamen(lInListePos)
            If sMembername <> "" Then ' wenn iPart/iAssembly vorliegt
                sSepFilename = sBasePath & "\" & sMembername & conSeparation & Right(oSourceDoc.FullFileName, 4)
            Else
                sSepFilename = CreateSepFilename(sBasePath, oSourceDoc)
            End If
            sFilenamen(lInListePos) = sSepFilename
            Call oSourceDoc.SaveAs(sSepFilename, True)
            Call oSourceDoc.Close(True)
        End If
    Next
 
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen gegen die separierten Bauteile/-gruppen ersetzen
    For lInListePos = lListenpos - 1 To 1 Step -1
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            'falls es eine Assembly ist, analysieren
            If LCase(Right(sFilenamen(lInListePos), 3) = "iam") Then
                ' iam öffnen
                Set oAssDoc = oapp.Documents.Open(sFilenamen(lInListePos))
                ' wenn iAssembly, dann ist membername gesetzt ...
                If sMembernamen(lInListePos) <> "" Then
                    ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                    If Not (oAssDoc.ComponentDefinition.iAssemblyFactory.DefaultRow.MemberName = sMembernamen(lInListePos)) Then
                        ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                        For Each oAssRow In oAssDoc.ComponentDefinition.iAssemblyFactory.TableRows
                            If oAssRow.MemberName = sMembernamen(lInListePos) Then
                                oAssDoc.ComponentDefinition.iAssemblyFactory.DefaultRow = oAssRow
                                Exit For
                            End If
                        Next
                    End If
                    oAssDoc.DisplayName = sMembernamen(lInListePos)
                End If
                ' Tabelle löschen wenn iAss-Factory angelegt ist
                If oAssDoc.ComponentDefinition.IsiAssemblyFactory Then Call oAssDoc.ComponentDefinition.iAssemblyFactory.Delete
                ' alle referenzierten Komponenten durchlaufen...
                For Each oSourceDoc In oAssDoc.ReferencedDocuments
                    sVorhandenerFilename = oSourceDoc.FullDocumentName ' vorhandener Namen der Komponenten zum Austausch merken
                    sSepFilename = sBasePath & "\" & GetDocumentName(oSourceDoc) & conSeparation & Right(oSourceDoc.FullFileName, 4)
                 
                    If oFileSystem.FileExists(sSepFilename) Then ' Occurrence auszutauschen, wenn File vorliegt
                        For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                            If Not (oOcc.ReferencedDocumentDescriptor Is Nothing) Then
                                If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                                    Call oOcc.Replace(sSepFilename, False)
                                End If
                            End If
                        Next
                    End If
                Next
                Call oAssDoc.BrowserPanes.ActivePane.Update
                Call oAssDoc.Update
                ' speichern und schließen
                Call oAssDoc.Save
                'If InStr(oAssDoc.FullFileName, conSeparation) > 0 Then Call oAssDoc.SaveAs(Replace(oAssDoc.FullFileName, conSeparation, ""), True)
                Call oAssDoc.Close(True)
            ElseIf LCase(Right(sFilenamen(lInListePos), 3) = "ipt") Then 'falls es ein iPart ist, dann...
                Set oPartDoc = oapp.Documents.Open(sFilenamen(lInListePos))
                ' wenn nicht durch Zufall aktive Zeile schon das gesuchte Kind ist, dann
                If Not (oPartDoc.ComponentDefinition.iPartFactory.DefaultRow.MemberName = sMembernamen(lInListePos)) Then
                    ' alle Zeilen durchlaufen bis richtiges Kind gefunden ist, dieses dann aktiv setzen
                    For Each oPartRow In oPartDoc.ComponentDefinition.iPartFactory.TableRows
                        If oPartRow.MemberName = sMembernamen(lInListePos) Then
                            oPartDoc.ComponentDefinition.iPartFactory.DefaultRow = oPartRow
                            Exit For
                        End If
                    Next
                End If
                oPartDoc.DisplayName = sMembernamen(lInListePos)
                ' Tabelle löschen
                Call oPartDoc.ComponentDefinition.iPartFactory.Delete
                ' Speichern die zweite und schließen
                Call oPartDoc.Update
                Call oPartDoc.Save
                Call oPartDoc.Close(True)
            End If
        End If
    Next
End Sub

' ggf abschließende Operation, die Originalnamen statt der separierten zu tauschen.
Private Sub ÄndereInOriginalnamen()
    Dim lInListePos As Long
    Dim oapp As Inventor.Application
    Set oapp = ThisApplication
 
    Dim sSepFilename As String
    Dim sVorhandenerFilename As String
 
    Dim oFileSystem As Object
    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    Dim oOcc As ComponentOccurrence
 
    Dim oAssDoc As AssemblyDocument ' für iAssembly-Abwicklung

    Dim oSourceDoc As Document
    ' Liste rückwärts durchlaufen und Bauteile/Baugruppen unter Namen OHNE Separation speichern
    For lInListePos = lListenpos - 1 To 1 Step -1 ' bis zum zweitersten, denn das erste File ist schon gespeichert worden.
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            Set oSourceDoc = oapp.Documents.Open(sFilenamen(lInListePos))
            sSepFilename = Replace(sFilenamen(lInListePos), conSeparation, "")
            Call oSourceDoc.SaveAs(sSepFilename, True)
            Call oSourceDoc.Close(True)
        End If
    Next
 
    ' Liste rückwärts durchlaufen und separierten Bauteile/Baugruppen gegen die Bauteile/-gruppen mit Originalnamen ersetzen
    For lInListePos = lListenpos - 1 To 1 Step -1
        If bAustauschenNötig(lInListePos) And (sFilenamen(lInListePos) <> "") Then
            'falls es eine Assembly ist, analysieren
            If LCase(Right(sFilenamen(lInListePos), 3) = "iam") Then
                ' iam öffnen
                Set oAssDoc = oapp.Documents.Open(Replace(sFilenamen(lInListePos), conSeparation, ""))
                ' wenn iAssembly, dann ist membername gesetzt ...
                For Each oSourceDoc In oAssDoc.ReferencedDocuments
                    sVorhandenerFilename = oSourceDoc.FullDocumentName ' vorhandener Namen der Komponenten zum Austausch merken
                    If InStr(sVorhandenerFilename, conSeparation) > 0 Then ' wenn als separiertes Bauteil gespeichert
                        sSepFilename = Replace(sVorhandenerFilename, conSeparation, "")
                        If oFileSystem.FileExists(sSepFilename) Then ' Occurrence auszutauschen, wenn File ohne -separiert vorliegt
                            For Each oOcc In oAssDoc.ComponentDefinition.Occurrences
                                If Not (oOcc.ReferencedDocumentDescriptor Is Nothing) Then
                                    If oOcc.ReferencedDocumentDescriptor.FullDocumentName = sVorhandenerFilename Then
                                        Call oOcc.Replace(sSepFilename, False)
                                        Call MarkFilenameInListe(sVorhandenerFilename)
                                    End If
                                End If
                            Next
                        End If
                    End If
                Next
             
                Call oAssDoc.BrowserPanes.ActivePane.Update
                Call oAssDoc.Update
                ' speichern und schließen
                Call oAssDoc.Save
                Call oAssDoc.Close(True)
            End If
        End If
    Next
 
    ' Liste durchlaufen und zum Löschen markierte Bauteile/Baugruppen löschen
    For lInListePos = 1 To lListenpos - 1
        If bLöschenNötig(lInListePos) Then Kill sFilenamen(lInListePos)
    Next
End Sub

' Löscht ohne Rückfrage den gesamten Ordner OldVersions
Private Sub LöscheOldVersions(sOVPath As String)
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.DeleteFolder (sOVPath & "\OldVersions")
    Set objFSO = Nothing
End Sub

' gibt Dateiname ohne Erweiterung zurück
Private Function GetDocumentName(ByVal odoc As Document) As String
    Dim oFileName As String
    oFileName = odoc.FullDocumentName
 
    Dim sName As String
    sName = Mid(oFileName, InStrRev(oFileName, "\") + 1)
 
    GetDocumentName = Left(sName, Len(sName) - 4)
End Function

' erzeugt den separierten SepFullFilename
Private Function CreateSepFilename(sBasePath As String, ByVal odoc As Document) As String
    CreateSepFilename = sBasePath & "\" & GetDocumentName(odoc) & conSeparation & Right(odoc.FullFileName, 4)
End Function
     

' löscht globale Liste der rekursiv erfassten Bauteile/Baugruppen
Private Sub ClearInListe()
    Dim lL As Long
 
    lListenpos = 1
    For lL = 1 To maxFeldgrösse - 1
        Call AddInListe("", "")
    Next
    lListenpos = 1
End Sub

' trägt die übergebenen File- und Membernamen in die globale Liste der rekursiv erfassten Bauteile/Baugruppen
Private Function AddInListe(ByVal sNeuerName As String, ByVal sNeuerMembername As String) As Long
    sFilenamen(lListenpos) = sNeuerName
    sMembernamen(lListenpos) = sNeuerMembername
    bAustauschenNötig(lListenpos) = (sNeuerName <> "") ' sicherheitshalber auf true setzen, wenn Name gesetzt, sonst false
    bLöschenNötig(lListenpos) = False
 
    AddInListe = lListenpos
 
    If lListenpos < maxFeldgrösse Then
        lListenpos = lListenpos + 1
    Else
        MsgBox "maxFeldgrösse=" & maxFeldgrösse & " zu gering.", vbExclamation
    End If
End Function

' marks in global list the member which has to be killed
Private Sub MarkFilenameInListe(ByVal sKillName As String)
    Dim lL As Long
    Dim sSearchMembername As String
 
    sSearchMembername = Mid(sKillName, InStrRev(sKillName, "\") + 1)
    sSearchMembername = Replace(sSearchMembername, conSeparation, "")
    For lL = 1 To maxFeldgrösse - 1
        If sFilenamen(lL) <> "" Then
            If sMembernamen(lL) & Right(sFilenamen(lL), 4) = sSearchMembername Or _
                Mid(sFilenamen(lL), InStrRev(sFilenamen(lL), "\")) = Mid(sKillName, InStrRev(sKillName, "\")) Then
                bLöschenNötig(lL) = True
                sFilenamen(lL) = sKillName
                Exit For
            End If
        End If
    Next
End Sub

' Funtion holt sich Baugruppennamen vom Benutzer
Private Function HoleNeuenBGNamen(sFDText As String, sDefaultName As String) As String
    Dim sPfad As String
    Dim sExtention As String
 
    ' Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)

    sExtention = "iam"
    If sDefaultName <> "" Then
        sExtention = Right(sDefaultName, 3)
    End If
    ' Define the filter to select part and assembly files or any file.
    oFileDlg.Filter = "Inventor Files (*." & sExtention & ")|*." & sExtention ' & "|All Files (*.*)|*.*"
    ' Define the part and assembly files filter to be the default filter.
    oFileDlg.FilterIndex = 1
    ' Set the title for the dialog.
    oFileDlg.DialogTitle = sFDText

    ' Set the initial directory that will be displayed in the dialog.
    sPfad = ThisApplication.ActiveDocument.FullFileName
    sPfad = Left(sPfad, InStrRev(sPfad, "\"))
    oFileDlg.InitialDirectory = sPfad
    oFileDlg.FileName = sDefaultName
  ' Show the open dialog.  The same procedure is also used for the Save dialog.
    oFileDlg.ShowSave

    HoleNeuenBGNamen = oFileDlg.FileName
End Function

---

------------------
IV2008

[Diese Nachricht wurde von st.w am 10. Apr. 2013 editiert.]

Und macht auch mittlerweile bei Schweißkonstruktionen keine Fehlermeldung mehr   

[Diese Nachricht wurde von st.w am 11. Apr. 2013 editiert.]

Aller guten Dinge sind 3: Jetzt auch inkl. iParts, extrahiert also universell. Und der Dateiname wird vorgeschlagen. Ich glaub' jetzt ist es rund, daher auch der protzige Name iExtract  

[Diese Nachricht wurde von st.w am 11. Apr. 2013 editiert.]

Na gut, es hat sich gezeigt, dass die Änderung in Originalnamen immer erfolgen muß, sonst sind noch alte Referenzen offen, die ständigen Aktualiserungbedarf bei der Zeichnungserstellung melden. Jetzt okay.

[Diese Nachricht wurde von st.w am 18. Apr. 2013 editiert.]

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