已更新 Hi Artem
I write a code to add a subconfiguration and remove all color for this active configuration,now i use the callresel to add color for the face that i select.but the color on the face of other configuration will be lose.
You can run the CreMfgSubConfig_onOK code before choose two face on the active configuration.
and you can download the file by the attachment.
Dim isFaceSel As Boolean
Dim swapp As SldWorks.SldWorks
Dim swSelMgr As SldWorks.SelectionMgr
Dim myFaceColl As Collection
Dim myEdgeColl As Collection
Dim myVertColl As Collection
Dim myPlaneColl As Collection
Dim swDoc As SldWorks.ModelDoc2
Dim myEnt As SldWorks.Entity
Dim mySafeEnt As SldWorks.Entity
Dim myFeat As SldWorks.Feature
Public configName As String
Public Sub CreMfgSubConfig_onOK()
Initialize_swSelection
Call SaveSels(False)
If isFaceSel = False Then Exit Sub
addSubConfig
RemoveAllColor '2016-8-7 去掉子配置里的颜色，然后再添加新的颜色
Call ReSel(False)
addColor
End Sub
Public Function addSubConfig() As Boolean
addSubConfig = True
Dim swapp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swconfig As SldWorks.Configuration
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swSubConfig As SldWorks.Configuration
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
Set swconfig = swModel.GetActiveConfiguration
Set swConfigMgr = swModel.ConfigurationManager
Set swSubConfig = swConfigMgr.AddConfiguration("subMfgName", "", "", 1, swconfig.Name, "Mfg by ICT API")
swModel.EditRebuild3
End Function
Public Sub RemoveAllColor()
Dim swapp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPrt As SldWorks.PartDoc
Dim swconfig As SldWorks.Configuration
Dim ConfigNames As Variant
Dim swBodies() As SldWorks.Body2
Dim swBody As SldWorks.Body2
Dim vBody As Variant
Dim vBodyArr As Variant
Dim path As String
Dim vconfigname As String
Dim swFaces() As Face2
Dim swFace As Face2
Dim vFace As Variant
Dim vprops As Variant
Dim bRet As Boolean
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
Set swPrt = swModel
swBodies = swPrt.GetBodies2(swAllBodies, True)
For Each vBody In swBodies
Set swBody = vBody
swFaces = swBody.GetFaces()
For Each vFace In swFaces
Set swFace = vFace
bRet = swFace.RemoveMaterialProperty2(1, Empty)
Next
Next
End Sub
Public Sub addColor()
Dim swapp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelExt As SldWorks.ModelDocExtension
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFace As SldWorks.Face2
Dim Faces() As SldWorks.Face2
Dim vprops(8) As Double
Dim bRet As Boolean
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
Set swModelExt = swModel.Extension
If swModelExt.LinkedDisplayState = False Then
MsgBox "显示状态未设置链接至配置"
swModelExt.LinkedDisplayState = True
MsgBox swModelExt.LinkedDisplayState & " ( " & "设置成功)"
End If
Set swSelMgr = swModel.SelectionManager
Dim vFaces As Variant
Dim i As Integer
vprops(0) = 1
vprops(1) = 0
vprops(2) = 1
vprops(3) = 1
vprops(4) = 1
vprops(5) = 0.8
vprops(6) = 0.3125
vprops(7) = 0
vprops(8) = 0
For i = 1 To swSelMgr.GetSelectedObjectCount2(0)
Set swFace = swSelMgr.GetSelectedObject6(i, -1)
swFace.SetMaterialPropertyValues2 vprops, swInConfigurationOpts_e.swThisConfiguration, Empty
Next i
swModel.ClearSelection2 True
End Sub
Sub Initialize_swSelection()
Set swapp = Application.SldWorks
Set swDoc = swapp.ActiveDoc
Set swSelMgr = swDoc.SelectionManager
Set myFaceColl = New Collection
End Sub
Private Sub SaveSels(bAdd As Boolean)
Dim i As Long
isFaceSel = False
If Not bAdd Then
Set myFaceColl = New Collection
End If
For i = 1 To swSelMgr.GetSelectedObjectCount
If swSelMgr.GetSelectedObjectType3(i, -1) = swSelFACES Then
isFaceSel = True
Set myEnt = swSelMgr.GetSelectedObject6(i, -1)
myFaceColl.Add myEnt.GetSafeEntity
End If
Next i
If isFaceSel = False Then
MsgBox "没有面被选中"
Exit Sub
End If
End Sub
Private Sub ReSel(bAdd As Boolean)
If Not (swapp.ActiveDoc Is swDoc) Then
MsgBox "The currently saved set is not in this document."
Exit Sub
End If
If Not bAdd Then
swDoc.ClearSelection2 True
End If
For Each myEnt In myFaceColl
If myEnt.Select(True) Then
Else
' Me.labMissingFaces.Caption = Me.labMissingFaces.Caption + 1
End If
Next
End Sub
