Dim swApp As SldWorks.SldWorks

    Dim swModel As SldWorks.ModelDoc2

    Dim swPart As SldWorks.PartDoc

    Dim swFeat As SldWorks.Feature

    Dim swFaceFeat As SldWorks.Feature

    Dim swSelMgr As SldWorks.SelectionMgr

    Dim swFace As SldWorks.Face2

    Dim swEnt As SldWorks.Entity

    Dim faceArr As Variant

    Dim oneFace As Variant

    Dim status As Boolean

    Dim Area As Double

    Dim TotalArea As Double

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

    Set swPart = swModel

    Set swSelMgr = swModel.SelectionManager

        Set swFeat = swSelMgr.GetSelectedObject6(1, -1)

        faceArr = swFeat.GetFaces: If IsEmpty(faceArr) Then Exit Sub

        For Each oneFace In faceArr

            Set swFace = oneFace

            Set swEnt = swFace

            Set swFaceFeat = swFace.GetFeature

            If swFaceFeat Is swFeat Then

         vProps = swFace.GetMaterialPropertyValues2(1, Empty)

         vProps(0) = 0.5

         vProps(1) = 1

         vProps(2) = 0.5

         vProps(3) = 0

         vProps(4) = 0

         vProps(5) = 0

         vProps(6) = 0

         vProps(7) = 0

         vProps(8) = 0

         swFace.SetMaterialPropertyValues2 vProps, 1, Empty

swModel.ClearSelection2 True

            End If

        Next

End Sub