AnsweredAssumed Answered

VBA Appearance Editing

Question asked by Willie Roelofs on Jul 24, 2015
Latest reply on Aug 19, 2015 by Willie Roelofs



I have multiple parts (over 100) that need the exact same appereance. Currently I'm doing the following:


- Remove all appearances;

- Right-click the apearance task manager to  "add new appearance";

- Select Dark Powder Coat;

- Edit Appearance;

     - Give the color

          - R0 G0 B255

          - H240 S100 V100

     - Remap the appearance to:

          - Width: 10[mm]

          - Height: 10[mm]


I've tried doing it, but the only thing I'm doing is editing the color of the appearance allready in use:


Sub main()


    Dim swApp As SldWorks.SldWorks

    Dim swModelDoc As SldWorks.ModelDoc2

    Dim swModelDocExt As SldWorks.ModelDocExtension

    Dim swSelMgr As SldWorks.SelectionMgr

    Dim swDisplayStateSetting As SldWorks.DisplayStateSetting

    Dim swComponent As SldWorks.Component2

    Dim swComponents(0) As SldWorks.Component2

    Dim swConfig As SldWorks.Configuration

    Dim displayStateNames(0) As String

    Dim appearances As Variant

    Dim swAppearanceSetting As SldWorks.AppearanceSetting

    Dim swConfigMgr As SldWorks.ConfigurationManager

    Dim newAppearances(0) As Object

    Dim status As Boolean

    Dim errors As Long

    Dim warnings As Long

    Dim fileName As String

    Dim red_rgb As Long

    Dim green_rgb As Long

    Dim blue_rgb As Long

    Dim newColor As Long


    Set swApp = Application.SldWorks


    'Open the assembly component USB_cover1 as a part document

    Set swModelDoc = swApp.ActiveDoc



    Set swModelDocExt = swModelDoc.Extension

    Set swSelMgr = swModelDoc.SelectionManager

    Set swConfigMgr = swModelDoc.ConfigurationManager

    Set swConfig = swConfigMgr.ActiveConfiguration

    Set swRenderMaterial = swModelDocExt.CreateRenderMaterial(MaterialName)

    Set swComponents(0) = Nothing

    Set swComponents(0) = swConfig.GetRootComponent3(True)


    swModelDoc.ClearSelection2 True


    'Get display state

    Set swDisplayStateSetting = Nothing

    Set swDisplayStateSetting = swModelDocExt.GetDisplayStateSetting(swAllDisplayState)

    swDisplayStateSetting.Entities = swComponents

    swDisplayStateSetting.Option = swSpecifyDisplayState

    displayStateNames(0) = "<Default>_Display State 1"

    swDisplayStateSetting.Names = displayStateNames

    appearances = swModelDocExt.DisplayStateSpecMaterialPropertyValues(swDisplayStateSetting)


    Set swAppearanceSetting = Nothing

    Set swAppearanceSetting = appearances(0)

    red_rgb = 0

    green_rgb = 0

    blue_rgb = 255

    newColor = Excel.WorksheetFunction.Max(Excel.WorksheetFunction.Min(red_rgb, 255), 0) + Excel.WorksheetFunction.Max(Excel.WorksheetFunction.Min(green_rgb, 255), 0) * 16 * 16 + Excel.WorksheetFunction.Max(Excel.WorksheetFunction.Min(blue_rgb, 255), 0) * 16 * 16 * 16 * 16

    swAppearanceSetting.Color = newColor

    Set newAppearances(0) = swAppearanceSetting

    swModelDocExt.DisplayStateSpecMaterialPropertyValues(swDisplayStateSetting) = newAppearances

    swRenderMaterial.BumpTextureFilename = "color"


    Set swModel = swApp.ActiveDoc


    swModel.ShowNamedView2 "*Isometric", 7



    FilePath = swModel.GetPathName

    swModel.SaveAs FilePath


    swApp.CloseDoc swModel.GetTitle


End Sub




Please help.