Hallo API Profis,
ich bin die letzten Wochen verzweifelt am Programmieren eines Macros das folgendes erfüllen soll:
In einer Baugruppe werden Komponenten mit einem Erscheinungsbild (Farbe) umgefärbt. Das Teil an sich hat dabei eine andere Farbe. z.B. Baugruppe A besteht aus 3 Einzelteilen Nr. Teil_1 in Farbe Blau. In Baugruppe A wird ein Teil_1 nur auf Baugruppenebene auf Rot umgefärbt.
Bitte schaut Euch die JPG dazu an, dann wird es verständlichen.
Bis jetzt kann ich mit folgendem Macro die Baugruppenstruktur auslesen und die Farbangabe (nur leider falsch).
-----------------------------------------------------------------------------------
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim swADoc As SldWorks.AssemblyDoc
Dim varComp As Variant
Dim swRenderMaterial As SldWorks.RenderMaterial
Dim SelMgr As SldWorks.SelectionMgr
Dim boolstatus As Boolean
Dim swComp As SldWorks.Component2
Dim valueSurface As String
Function TraverseComponents(parentComp As SldWorks.Component2)
Dim vChildComponents As Variant
Dim vObj As Variant
Dim childComp As SldWorks.Component2
Dim childDoc As SldWorks.ModelDoc2
Dim childConfigName As String
vChildComponents = parentComp.GetChildren
For Each vObj In vChildComponents
Set childComp = vObj
Set childDoc = childComp.GetModelDoc
childConfigName = childComp.ReferencedConfiguration
'_____________hier wird das Erscheinungsbild der Komponenten ausgelesen____________________________________________
Set swADoc = Part
'varComp = swADoc.GetComponents(True) 'hier gibt es eine falsche Anzeige!!!
varComp = swADoc.GetComponents(False)
Dim I As Long
Dim compName As String
For I = LBound(varComp) To UBound(varComp)
Dim swComp As SldWorks.Component2
Dim count As Integer
Set swComp = varComp(I)
'Set swComp = varComp(2) 'bis 8 gehen die Componenten
Set swRenderMaterial = swComp.IGetRenderMaterials(count)
If Not (swRenderMaterial Is Nothing) Then
valueSurface = swRenderMaterial.FileName
End If
Next I
varComp = Empty
'__________________________________________________________________________________________________
Debug.Print childComp.Name2 & " " & valueSurface
Call TraverseComponents(childComp)
Next vObj
End Function
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Dim rootDoc As SldWorks.ModelDoc2
Dim rootConfig As SldWorks.Configuration
Dim rootComp As SldWorks.Component2
Dim configMgr As SldWorks.ConfigurationManager
Dim Model As Object
swApp.Visible = True
Set Model = swApp.ActiveDoc
Set rootDoc = swApp.ActiveDoc
Set configMgr = Part.ConfigurationManager
Set rootConfig = configMgr.ActiveConfiguration
Set rootComp = rootConfig.GetRootComponent
Call TraverseComponents(rootComp)
End Sub
---------------------------------------------------------------------------------------------
Vielleicht hat von Euch jemand eine Idee, wo ich falsch liege.
------------------
Viele Grüße
Peter
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP