Hallo zusammen,
ich habe ein Problem mit meinem Makro. Dieses Makro soll alle Bauteile die in einer Baugruppe vorhanden sind überprüfen ob diese unterdrückt sind oder nicht.
Diese sollen wenn Sie unterdrückt sind in ein anderes Array geschrieben werden. Mit diesem Array möchte ich alle Bauteile zusammen löschen.
Ich habe schon ein ähnliches Makro. Dort überprüfe und lösche ich alle Bauteile einzeln. Das funktioniert, auch dauert nur sehr lange.
Als ich dann über den Befehl Multiselect gestolpert bin und gemerkt habe damit kann ich viel schneller löschen wollte ich das Makro umschreiben
Ich vermute das Problem ist dass, das Objekt nicht von dem einen in den anderen Array geschrieben wird.
Option Explicit
Dim swApp As SldWorks.SldWorks 'Variable für Applikation deklarieren (global)
Dim swModel As SldWorks.ModelDoc2 'Variable für Model deklarieren (global)
Dim swDocType As Integer 'Variable für Dateityp deklarieren (global)
Dim swModelExt As SldWorks.ModelDocExtension 'Variable für Modelerweiterung deklarieren (global)
Dim swAssembly As AssemblyDoc 'Variable für die geöffnete Baugruppe deklarieren (global)
Dim allComponents As Variant 'Alle Komponenten der geöffneten Baugruppe (global)
Dim allDeleteComponents() As Variant 'Alle zu löschenden Komponenten (global)
Dim intI As Long 'Anzahl der zu löschenden Komponenten (global)
'--------------------------------------------------------------------------------------------------------------------------------------------------------
'Unterdrückte Bauteile aus Baugruppe löschen
'--------------------------------------------------------------------------------------------------------------------------------------------------------
Sub main()
'Baugruppenabfrage
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelExt = swModel.Extension
'Prüfen ob ein aktives Solidworksmodel vorhanden ist
If swModel Is Nothing Then
'Wenn kein aktives Model vorhanden ist dann Makro Ende
swApp.SendMsgToUser "Kein Dokument geladen!"
End
End If
'Typ des aktiven Solidworksmodel zuweisen
swDocType = swModel.GetType
'Prüfen ob das Aktive Solidworksmodel ein Assambly ist
If swDocType <> swDocASSEMBLY Then
'Wenn kein Assambly dann Makro Ende
swApp.SendMsgToUser "Dieses Makro funktioniert nur in einem Assambly"
End
End If
LoadComponents
End Sub
Sub LoadComponents()
'Baugruppe deklarieren und zuweisen aus Model
Set swAssembly = swModel
'Alle Bauteile aus Baugruppe auslesen
allComponents = swAssembly.GetComponents(True) 'true = toplevel / false = childcomponents
'Alle Bauteile aus Baugruppe zählen
Dim componentCount As Long
componentCount = swAssembly.GetComponentCount(True) 'true = toplevel / false = childcomponents
ReDim allDeleteComponents(componentCount - 1)
Dim boolstatus As Boolean
'Anzahl zu behaltender Bauteile
intI = 0
'Anzahl Durchlaufener schleifen
Dim intJ As Long
intJ = 0
'Variable für bauteile in Baugruppe deklarieren
Dim component As Variant
For Each component In allComponents
'Variable für sld Components festgelegt und auslesen
Dim swComponent2 As SldWorks.component2
Set swComponent2 = component
'Unterdrückungsstatus auslesen
Dim SuppressionState As Integer
SuppressionState = swComponent2.GetSuppression2
'Bauteil anzahl die gelöscht werden soll wird ermittelt
If SuppressionState = swComponentSuppressed Then
Set allDeleteComponents(intI) = allComponents(intJ)
'Debug.Print allDeleteComponents(intI)
Debug.Print SuppressionState & " " & swComponent2.name
intI = intI + 1
End If
Debug.Print SuppressionState & " " & swComponent2.name
intJ = intJ + 1
Next
If intI = 0 Then
MsgBox "Keine unterdrückten Komponenten vorhanden." & vbNewLine & vbNewLine & "Makro wird beendet!"
End
End If
Debug.Print "____"
ReDim allDeleteComponents(intI)
Dim längearr
längearr = UBound(allDeleteComponents)
Debug.Print "____"
Debug.Print componentCount
Debug.Print längearr
Debug.Print intI
Debug.Print intJ
boolstatus = swModelExt.MultiSelect2(allDeleteComponents, False, Nothing)
swModel.EditDelete
' boolstatus = swModelExt.MultiSelect2(allComponents, False, Nothing)
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
.
.
