---

Hallo zusammen,

ich bin auf der Suche nach einem Makro, das alle Bauteile / Baugruppen in einer BG fixiert und dabei eventuelle Komponentenanordnungen mit einbezieht.

Ich bin mir sicher, das ich dieses Makro schonmal bei CAD.de gesehen habe, aber ich finde es nicht wieder.

Kann jemand meinem Gedächtnis auf die Sprünge helfen?

Momentan verwenden wir ein Makro, das abbricht, sobald eine Komponentenanordnung mit ausgewählt wurde.

vielen dank im voraus

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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

---

Ich habe hier dieses Makro, das alle markierten Komponenten an den Ursprung verschiebt und dort fixiert. Mußt Du nur entsprechend zusammen streichen  .

Code:

---

Sub GroundFix()

    If ThisApplication.Documents.Count = 0 Then
        MsgBox "Es ist kein Dokument geöffnet!", 0, "Fehler"
        Exit Sub
    End If
 
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
        MsgBox "Das geöffnete Dokument ist keine Baugruppe!", 0, "Fehler"
        Exit Sub
    End If
   
    Dim oAsm As AssemblyDocument
    Set oAsm = ThisApplication.ActiveDocument
 
    If oAsm.SelectSet.Count = 0 Then
        MsgBox "Es sind keine Komponenten selektiert"
        Exit Sub
    End If
 
    Dim oOcc As ComponentOccurrence
    Dim oTransformation As Matrix
 
    Dim oMatrix As Matrix
    Set oMatrix = ThisApplication.TransientGeometry.CreateMatrix
 
    Dim dCells(15) As Double
    Call oMatrix.GetMatrixData(dCells)
 
    For Each oOcc In oAsm.SelectSet
        Call oMatrix.PutMatrixData(dCells)
        oOcc.Transformation = oMatrix
        oOcc.Grounded = True
    Next
   
End Sub

---

------------------
Cheers,
    Jochen

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

---

Halloo Jochen,

Auf Ursprung verschieben haben wir auch.
Mir geht es darum hier

Code:

---

Sub Markierte_Bauteile_Fixieren()
    If ThisApplication.Documents.Count = 0 Then
        MsgBox "Keine Dokumente geöffnet"
        Exit Sub
    End If
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
        MsgBox "Das geöffnete Dokument ist keine Baugruppe"
        Exit Sub
    End If
    Dim oAsm As AssemblyDocument
    Set oAsm = ThisApplication.ActiveDocument
    If oAsm.SelectSet.Count = 0 Then
        MsgBox "Es sind keine Komponenten selektiert"
        Exit Sub
    End If
    Dim oOcc As ComponentOccurrence
    Dim oConstraint As AssemblyConstraint
    For Each oOcc In oAsm.SelectSet
        If oOcc.Constraints.Count > 0 Then
          For Each oConstraint In oOcc.Constraints
              oConstraint.Suppressed = True
          Next
        End If
        oOcc.Grounded = True
    Next
End Sub

---

eventuelle Komponentenanordnungen mit einzubeziehen, ohne jedes Bauteil der Anordnung auswählen zu müssen.

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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

---

Ehrlich gesagt kam ich noch nie auf die Idee, alle Komponenten einer Anordnung zu fixieren. Der Code sieht im Prinzip gleich aus, also wird bei meinem Makro das gleiche Problem auftreten. 

------------------
Cheers,
    Jochen

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

---

Hallo

Hab schnell mal was gestrickt für Anordnungen.

Code:

---

Option Explicit

Private Sub Fix_Selected_PatternElements()

Dim oAssDoc As AssemblyDocument
Set oAssDoc = ThisApplication.ActiveDocument

Dim oSelSet As SelectSet
Set oSelSet = oDoc.SelectSet

Dim oObject As Object
Dim oCompOccsEnum As ComponentOccurrencesEnumerator
Dim oCompOcc As ComponentOccurrence
Dim oPattern As OccurrencePatternElement

For Each oObject In oSelSet
    If TypeOf oObject Is OccurrencePattern Then
        For Each oPattern In oObject.OccurrencePatternElements
            For Each oCompOcc In oPattern.Occurrences
                If oCompOcc.SubOccurrences.Count = 0 Then
                    If oCompOcc.DefinitionDocumentType = kPartDocumentObject Then
                        If oCompOcc.IsSubstituteOccurrence = False Then
                            oCompOcc.Grounded = True
                        End If
                    End If
                Else
                    oCompOcc.Grounded = True
                    Call AllSubOccs(oCompOcc)
                End If
            Next
        Next
    End If
Next
End Sub

Private Sub AllSubOccs(ByVal oCompOcc As ComponentOccurrence)
    Dim oSubCompOcc As ComponentOccurrence
    Dim oProp As Property
    Dim sValue As String
   
    On Error Resume Next
   
    For Each oSubCompOcc In oCompOcc.SubOccurrences
        If oSubCompOcc.SubOccurrences.Count = 0 Then
            If oSubCompOcc.DefinitionDocumentType = kPartDocumentObject Then
                If oSubCompOcc.IsSubstituteOccurrence = False Then
                    oSubCompOcc.Grounded = True
                End If
            Else
                oSubCompOcc.Grounded = True
                Call AllSubOccs(oSubCompOcc)
            End If
        End If
    Next
End Sub

---

------------------
MfG
RK

[Diese Nachricht wurde von rkauskh am 17. Feb. 2010 editiert.]

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

---

Danke RK,

ich werd mal versuchen, ob ich die beiden Makros zu einem zusammentüfteln kann.

Ü's sind schonmal unterwegs.

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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

---

Hallo nochmal,

nach längerem suchen ist mir ein Makro von Igor wieder in die Hände gefallen, das ungefähr das bewirkt, was ich gerne hätte.

Code:

---

'  Hauptfunktionen ----------------------------------------------------------------------------------------------------
Public Sub KomponentenFixieren()
    If ThisApplication.Documents.Count = 0 Then
    MsgBox "Die Baugruppe öffnen.", vbExclamation, "Keine Baugruppe"
        Exit Sub
    End If
 
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
        MsgBox "Die Baugruppe öffnen.", vbExclamation, "Keine Baugruppe"
        Exit Sub
    End If

    Dim oAsm As AssemblyDocument
    Set oAsm = ThisApplication.ActiveDocument

    ForAllComponents oAsm.ComponentDefinition.Occurrences
End Sub

Public Sub KomponentenFixierungAufheben()
    If ThisApplication.Documents.Count = 0 Then
    MsgBox "Die Baugruppe öffnen.", vbExclamation, "Keine Baugruppe"
        Exit Sub
    End If
 
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
        MsgBox "Die Baugruppe öffnen.", vbExclamation, "Keine Baugruppe"
        Exit Sub
    End If

    Dim oAsm As AssemblyDocument
    Set oAsm = ThisApplication.ActiveDocument

    ForAllComponentsFree oAsm.ComponentDefinition.Occurrences
End Sub

'  Hilfsfunktionen ----------------------------------------------------------------------------------------------------
Sub ForAllComponents(oOccs As ComponentOccurrences)
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oOccs
        On Error Resume Next
        oOcc.Grounded = True
        If oOcc.Constraints.Count > 0 Then
          For Each oConstraint In oOcc.Constraints
              oConstraint.Suppressed = True
        Next
        End If
        ThisApplication.StatusBarText = oOcc.Name
        If Err.Number <> 0 Then
            Err.Number = 0
            GoTo NEXTCOMP
        End If
NEXTCOMP:
        ForAllComponents oOcc.SubOccurrences
    Next
End Sub

Sub ForAllComponentsFree(oOccs As ComponentOccurrences)
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oOccs
        On Error Resume Next
        oOcc.Grounded = False
        If oOcc.Constraints.Count > 0 Then
          For Each oConstraint In oOcc.Constraints
              oConstraint.Suppressed = False
        Next
        End If
        ThisApplication.StatusBarText = oOcc.Name
        If Err.Number <> 0 Then
            Err.Number = 0
            GoTo NEXTCOMP
        End If
NEXTCOMP:
        ForAllComponentsFree oOcc.SubOccurrences
    Next
End Sub
'  --------------------------------------------------------------------------------------------------------------------

---

Kann mir jemand sagen, wie ich dieses Makro so umstricke, das nur die aktuelle auswahl fixiert wird und nicht der komplette Modellbaum?

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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

---

Hallo

Nö, da das Teil unvollständig(?) ist.
Ich hab lieber meines erweitert. Nich schön,aber läuft.

Code:

---

Option Explicit

Private Sub Fix_Selected_Elements() 'and suppress constraints

Dim oDoc As AssemblyDocument
Set oDoc = ThisApplication.ActiveDocument

Dim oSel As SelectSet
Set oSel = oDoc.SelectSet

Dim oObject As Object
Dim oCompOccsEnum As ComponentOccurrencesEnumerator
Dim oCompOcc As ComponentOccurrence
Dim oPattern As OccurrencePatternElement
Dim oConstraint As Object

For Each oObject In oSel
    If TypeOf oObject Is OccurrencePattern Then
        For Each oPattern In oObject.OccurrencePatternElements
            For Each oCompOcc In oPattern.Occurrences
                If oCompOcc.SubOccurrences.Count = 0 Then
                    If oCompOcc.DefinitionDocumentType = kPartDocumentObject Then
                        If oCompOcc.IsSubstituteOccurrence = False Then
                            oCompOcc.Grounded = True
                            For Each oConstraint In oCompOcc.Constraints
                                oConstraint.Suppressed = True
                            Next
                        End If
                    End If
                Else
                    oCompOcc.Grounded = True
                    For Each oConstraint In oCompOcc.Constraints
                        oConstraint.Suppressed = True
                    Next
                    Call AllSubOccs(oCompOcc)
                End If
            Next
        Next
    Else
        If oObject.SubOccurrences.Count = 0 Then
            If oObject.DefinitionDocumentType = kPartDocumentObject Then
                If oObject.IsSubstituteOccurrence = False Then
                    oObject.Grounded = True
                    For Each oConstraint In oObject.Constraints
                        oConstraint.Suppressed = True
                    Next
                End If
            End If
        Else
            oObject.Grounded = True
            For Each oConstraint In oObject.Constraints
                oConstraint.Suppressed = True
            Next
            Call AllSubOccs(oObject)
        End If
    End If
Next
End Sub

Private Sub AllSubOccs(ByVal oCompOcc As ComponentOccurrence)
    Dim oSubCompOcc As ComponentOccurrence
    Dim oProp As Property
    Dim sValue As String
    Dim oConstraint As Object
   
    On Error Resume Next
   
    For Each oSubCompOcc In oCompOcc.SubOccurrences
        If oSubCompOcc.SubOccurrences.Count = 0 Then
            If oSubCompOcc.DefinitionDocumentType = kPartDocumentObject Then
                If oSubCompOcc.IsSubstituteOccurrence = False Then
                    oSubCompOcc.Grounded = True
                    For Each oConstraint In oSubCompOcc.Constraints
                        oConstraint.Suppressed = True
                    Next
                End If
            Else
                oSubCompOcc.Grounded = True
                For Each oConstraint In oSubCompOcc.Constraints
                    oConstraint.Suppressed = True
                Next
                Call AllSubOccs(oSubCompOcc)
            End If
        End If
    Next
End Sub

---

------------------
MfG
RK

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

---

Hallo RK,

danke auf jeden Fall schon mal für deine Mühe, werde es gleich mal testen. 

Was fehlt deiner Meinung nach am Makro? 
Bei mir läuft es einwandfrei.
Halt nur nicht auf ausgewählte Komponenten sondern den ganzen Modellbaum runter.

Ich melde mich wieder, wenn ich deins getestet habe. 

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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

---

Hallo

Bei mir quängelt er ein undefiniertes oConstraint an. Liegt daran, daß ich prinzipiell mit "Option explicit" arbeite und VB lieber nicht das erraten des Objekttyps überlasse.

------------------
MfG
RK

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

---

Das Problem mit dem oConstraint hab ich zwar nicht, aber danke für den Hinweis.

Dein Makro funktioniert wie erwartet.

Danke noch mal dafür.

------------------
Gruß, Gandhi
Zuerst ignorieren sie dich, dann lachen sie über dich, dann bekämpfen sie dich und dann gewinnst du.
CAD-RPG - Anleitungen IVNGWC

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