SOLIDWORKS VBA macro to copy preselected faces
Author: Eddy Alleman
{ width=525 }
This VBA macro creates a new surface feature from selected faces in a part file. Thus duplicating the selected surfaces and giving it a predefined color. This can be usefull if you want to reuse existing surfaces and don't want to consolidate existing ones.
Steps to take
- A part file must be the active document.
- You have to select at least one face.
- If you select other types of entities, they will be filtered out.
- Run the macro. As the result a Surface Offset is created of the selected faces with distance 0
- This feature will get a yellow color by default, but you can change the RGB color to set another one.
Author: Eddy Alleman (EDAL Solutions)
Option Explicit
' INPUT You can change to another RGB color here (This example uses yellow)
Const RED = 255
Const GREEN = 255
Const BLUE = 0
Dim swxApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim selMgr As SldWorks.SelectionMgr
Sub main()
try_:
On Error GoTo catch_
Set swxApp = Application.SldWorks
Set swModel = swxApp.ActiveDoc
'Check if active document is a Part file
Select Case True
Case swModel Is Nothing, swModel.GetType <> swDocPART
Call swxApp.SendMsgToUser2("Please open a part file", swMbInformation, swMbOk)
Case Else
Call ProcessSelectedFaces
End Select
GoTo finally_:
catch_:
MsgBox Err.Description
finally_:
End Sub
Private Function ProcessSelectedFaces() As Boolean
EnableUpdates False
Set selMgr = swModel.SelectionManager
'Get number of selections
Dim nSelections As Integer
nSelections = selMgr.GetSelectedObjectCount2(-1)
'only process if there is something selected
If nSelections > 0 Then
Call RemoveNonFacesFromSelection
'Get the number of selected faces
Dim nFaces As Integer
nFaces = selMgr.GetSelectedObjectCount2(-1)
If nFaces > 0 Then
'Offset selected faces
swModel.InsertOffsetSurface 0#, False
'Give a name to the newly created offset feature
Dim featOffset As Feature
Set featOffset = swModel.Extension.GetLastFeatureAdded
featOffset.Name = featOffset.Name & " Offsets " & nFaces & " Faces"
'give the offset feature a color
Call SetColor(featOffset)
' Deselect face to see new color
swModel.ClearSelection2 True
End If 'nFaces > 0
End If 'nSelections > 0
EnableUpdates True
End Function
Private Function EnableUpdates(update As Boolean)
With swModel
.FeatureManager.EnableFeatureTree = update
.ActiveView.EnableGraphicsUpdate = update
End With
End Function
'Removes entities that are not faces from the selection manager
Private Function RemoveNonFacesFromSelection()
'Get number of selections
Dim nSelections As Integer
nSelections = selMgr.GetSelectedObjectCount2(-1)
Dim i As Integer
For i = 0 To nSelections
Dim ObjectType As Long
ObjectType = selMgr.GetSelectedObjectType3(i, -1)
If ObjectType <> swSelectType_e.swSelFACES Then
Dim res As Boolean
res = selMgr.DeSelect2(i, -1)
End If
Next
End Function
'Sets the INPUT color on a feature
Private Function SetColor(ByRef Feat As Feature) As Boolean
'get material properties from model
Dim MatProp As Variant
MatProp = swModel.MaterialPropertyValues
' set color fi. RGB(225, 255 , 0), but we need them to be in range 0 to 1
MatProp(0) = RED / 255
MatProp(1) = GREEN / 255
MatProp(2) = BLUE / 255
SetColor = Feat.SetMaterialPropertyValues(MatProp)
End Function