Hello together,
a) how could I copy the color of each part of an assembly to the parts?
b) how could I copy the color from a part to another?
Tanky you
Georg
Hi Georg,
You can get the Appearance asset from the ComponentOccurrence or source Part, and copy it into the target Part using code as follow:
Private Sub SetMaterialToPart() Dim oDoc As PartDocument Set oDoc = ThisApplication.ActiveDocument Dim Name As String Name = "Copper" Dim localAsset As Asset On Error Resume Next Set localAsset = oDoc.Assets.item(Name) If Err Then On Error GoTo 0 ' Failed to get the appearance ' in the document, so import it. ' Get an asset library by name. ' Either the displayed name (which ' can changed based on the current language) ' or the internal name ' (which is always the same) can be used. Dim assetLib As AssetLibrary Set assetLib = ThisApplication.AssetLibraries _ .item("Autodesk Material Library") 'Set assetLib = ThisApplication.AssetLibraries _ '.Item("AD121259-C03E-4A1D-92D8-59A22B4807AD") ' Get an asset in the library Dim libAsset As Asset Set libAsset = assetLib.MaterialAssets.item(Name) ' Copy the asset locally. Set localAsset = libAsset.CopyTo(oDoc) End If On Error GoTo 0 'set material to the part oDoc.ActiveMaterial = localAsset ' Select the top browser node of the model pane. ' This is a workaround to refresh materials info in the UI. Call oDoc.BrowserPanes.ActivePane.TopNode.DoSelect End Sub
Hope that helps,
Philippe.
If you want it to be compatible with 2014 and 2015, there is no way you can copy just the color, it is part of the material properties. In that case, you could determine which property in the appearance is defining the color and copy that color property in the target appearance.
Here is some code that will dump the appearance settings:
Public Sub GetAppearanceSettingsToFile() Dim doc As PartDocument Set doc = ThisApplication.ActiveDocument Dim appearance As Asset 'Set appearance = doc.Assets.item("Rot_Transparent") Set appearance = doc.ActiveAppearance Dim f As Integer f = FreeFile() Open "C:\Temp\" & appearance.DisplayName & ".txt" For Output As #f Print #f, "Appearance Name: " & appearance.DisplayName Dim value As AssetValue For Each value In appearance PrintAssetValueToFile f, value, 5 Next Close #f End Sub Private Function ColorToString(InColor As color) As String ColorToString = "[" & InColor.Red & ", " & InColor.Green & ", " & InColor.Blue & ", " & InColor.Opacity & "]" End Function Private Sub PrintAssetValue( _ ByRef inValue As AssetValue, _ ByRef indent As Long) Dim indentChars As String indentChars = space(indent) Debug.Print indentChars & "Value" Debug.Print indentChars & " DisplayName: " & inValue.DisplayName Debug.Print indentChars & " Name: " & inValue.Name Debug.Print indentChars & " IsReadOnly: " & inValue.IsReadOnly Select Case inValue.ValueType Case kAssetValueTextureType Debug.Print indentChars & " Type: Texture" Dim textureValue As TextureAssetValue Set textureValue = inValue Dim texture As AssetTexture Set texture = textureValue.value Select Case texture.TextureType Case kTextureTypeBitmap Debug.Print indentChars & " TextureType: kTextureTypeBitmap" Case kTextureTypeChecker Debug.Print indentChars & " TextureType: kTextureTypeChecker" Case kTextureTypeGradient Debug.Print indentChars & " TextureType: kTextureTypeGradient" Case kTextureTypeMarble Debug.Print indentChars & " TextureType: kTextureTypeMarble" Case kTextureTypeNoise Debug.Print indentChars & " TextureType: kTextureTypeNoise" Case kTextureTypeSpeckle Debug.Print indentChars & " TextureType: kTextureTypeSpeckle" Case kTextureTypeTile Debug.Print indentChars & " TextureType: kTextureTypeTile" Case kTextureTypeUnknown Debug.Print indentChars & " TextureType: kTextureTypeUnknown" Case kTextureTypeWave Debug.Print indentChars & " TextureType: kTextureTypeWave" Case kTextureTypeWood Debug.Print indentChars & " TextureType: kTextureTypeWood" Case Else Debug.Print indentChars & " TextureType: Unexpected type returned" End Select Debug.Print indentChars & " Values" Dim textureSubValue As AssetValue For Each textureSubValue In texture Call PrintAssetValue(textureSubValue, indent + 4) Next Case kAssetValueTypeBoolean Debug.Print indentChars & " Type: Boolean" Dim booleanValue As BooleanAssetValue Set booleanValue = inValue Debug.Print indentChars & " Value: " & booleanValue.value Case kAssetValueTypeChoice Debug.Print indentChars & " Type: Choice" Dim choiceValue As ChoiceAssetValue Set choiceValue = inValue Debug.Print indentChars & " Value: " & choiceValue.value Dim names() As String Dim choices() As String Call choiceValue.GetChoices(names, choices) Debug.Print indentChars & " Choices:" Dim i As Integer For i = 0 To UBound(names) Debug.Print indentChars & " " & names(i) & ", " & choices(i) Next Case kAssetValueTypeColor Debug.Print indentChars & " Type: Color" Dim colorValue As ColorAssetValue Set colorValue = inValue Debug.Print indentChars & " HasConnectedTexture: " & colorValue.HasConnectedTexture Debug.Print indentChars & " HasMultipleValues: " & colorValue.HasMultipleValues If Not colorValue.HasMultipleValues Then Debug.Print indentChars & " Color: " & ColorToString(colorValue.value) Else Debug.Print indentChars & " Colors" Dim colors() As color colors = colorValue.Values For i = 0 To UBound(colors) Debug.Print indentChars & " Color: " & ColorToString(colors(i)) Next End If Case kAssetValueTypeFilename Debug.Print indentChars & " Type: Filename" Dim filenameValue As FilenameAssetValue Set filenameValue = inValue Debug.Print indentChars & " Value: " & filenameValue.value Case kAssetValueTypeFloat Debug.Print indentChars & " Type: Float" Dim floatValue As FloatAssetValue Set floatValue = inValue Debug.Print indentChars & " Value: " & floatValue.value Case kAssetValueTypeInteger Debug.Print indentChars & " Type: Integer" Dim integerValue As IntegerAssetValue Set integerValue = inValue Debug.Print indentChars & " Value: " & integerValue.value Case kAssetValueTypeReference ' This value type is not currently used in any of the assets. Debug.Print indentChars & " Type: Reference" Dim refType As ReferenceAssetValue Set refType = inValue Case kAssetValueTypeString Debug.Print indentChars & " Type: String" Dim stringValue As StringAssetValue Set stringValue = inValue Debug.Print indentChars & " Value: """ & stringValue.value & """" End Select End Sub Private Sub PrintAssetValueToFile( _ ByRef f As Integer, _ ByRef inValue As AssetValue, _ ByRef indent As Long) Dim indentChars As String indentChars = space(indent) Print #f, indentChars & "Value" Print #f, indentChars & " DisplayName: " & inValue.DisplayName Print #f, indentChars & " Name: " & inValue.Name Print #f, indentChars & " IsReadOnly: " & inValue.IsReadOnly Select Case inValue.ValueType Case kAssetValueTextureType Print #f, indentChars & " Type: Texture" Dim textureValue As TextureAssetValue Set textureValue = inValue Dim texture As AssetTexture Set texture = textureValue.value Select Case texture.TextureType Case kTextureTypeBitmap Print #f, indentChars & " TextureType: kTextureTypeBitmap" Case kTextureTypeChecker Print #f, indentChars & " TextureType: kTextureTypeChecker" Case kTextureTypeGradient Print #f, indentChars & " TextureType: kTextureTypeGradient" Case kTextureTypeMarble Print #f, indentChars & " TextureType: kTextureTypeMarble" Case kTextureTypeNoise Print #f, indentChars & " TextureType: kTextureTypeNoise" Case kTextureTypeSpeckle Print #f, indentChars & " TextureType: kTextureTypeSpeckle" Case kTextureTypeTile Print #f, indentChars & " TextureType: kTextureTypeTile" Case kTextureTypeUnknown Print #f, indentChars & " TextureType: kTextureTypeUnknown" Case kTextureTypeWave Print #f, indentChars & " TextureType: kTextureTypeWave" Case kTextureTypeWood Print #f, indentChars & " TextureType: kTextureTypeWood" Case Else Print #f, indentChars & " TextureType: Unexpected type returned" End Select Print #f, indentChars & " Values" Dim textureSubValue As AssetValue For Each textureSubValue In texture Call PrintAssetValue(textureSubValue, indent + 4) Next Case kAssetValueTypeBoolean Print #f, indentChars & " Type: Boolean" Dim booleanValue As BooleanAssetValue Set booleanValue = inValue Print #f, indentChars & " Value: " & booleanValue.value Case kAssetValueTypeChoice Print #f, indentChars & " Type: Choice" Dim choiceValue As ChoiceAssetValue Set choiceValue = inValue Print #f, indentChars & " Value: " & choiceValue.value Dim names() As String Dim choices() As String Call choiceValue.GetChoices(names, choices) Print #f, indentChars & " Choices:" Dim i As Integer For i = 0 To UBound(names) Print #f, indentChars & " " & names(i) & ", " & choices(i) Next Case kAssetValueTypeColor Print #f, indentChars & " Type: Color" Dim colorValue As ColorAssetValue Set colorValue = inValue Print #f, indentChars & " HasConnectedTexture: " & colorValue.HasConnectedTexture Print #f, indentChars & " HasMultipleValues: " & colorValue.HasMultipleValues If Not colorValue.HasMultipleValues Then Print #f, indentChars & " Color: " & ColorToString(colorValue.value) Else Print #f, indentChars & " Colors" Dim colors() As color colors = colorValue.Values For i = 0 To UBound(colors) Print #f, indentChars & " Color: " & ColorToString(colors(i)) Next End If Case kAssetValueTypeFilename Print #f, indentChars & " Type: Filename" Dim filenameValue As FilenameAssetValue Set filenameValue = inValue Print #f, indentChars & " Value: " & filenameValue.value Case kAssetValueTypeFloat Print #f, indentChars & " Type: Float" Dim floatValue As FloatAssetValue Set floatValue = inValue Print #f, indentChars & " Value: " & floatValue.value Case kAssetValueTypeInteger Print #f, indentChars & " Type: Integer" Dim integerValue As IntegerAssetValue Set integerValue = inValue Print #f, indentChars & " Value: " & integerValue.value Case kAssetValueTypeReference ' This value type is not currently used in any of the assets. Print #f, indentChars & " Type: Reference" Dim refType As ReferenceAssetValue Set refType = inValue Case kAssetValueTypeString Print #f, indentChars & " Type: String" Dim stringValue As StringAssetValue Set stringValue = inValue Print #f, indentChars & " Value: """ & stringValue.value & """" End Select End Sub
Philippe.