I’m trying to run a macro to add several empty folders in feature tree.
After folders being created, different features will be manually drag into these folders.
The code at the bottom is what I have so far.
I’m receiving this error: run time error 438
Object doesn’t support this property.
on this line: Set swFeat = swFeatMgr.InsertFeatureTreeFolder3(1, 0)
Thanks for any kind of help.
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeatMgr As SldWorks.FeatureManager
Dim swFeat As SldWorks.Feature
Dim folderNames As Variant
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "No active model open.", vbCritical
Exit Sub
End If
Set swFeatMgr = swModel.FeatureManager
folderNames = Array("Body", "Ws", "Holes", "Studs", "Taps", "Brs", "Trims", "Locs", "Ens")
For i = LBound(folderNames) To UBound(folderNames)
Set swFeat = swFeatMgr.InsertFeatureTreeFolder3(1, 0)
If Not swFeat Is Nothing Then
swFeat.Name = folderNames(i)
Else
MsgBox "Folder creation failed on: " & folderNames(i)
Exit Sub
End If
Next i
End Sub
This line “Set swFeat = swFeatMgr.InsertFeatureTreeFolder3(1, 0)” should be “Set swFeat = swFeatMgr.InsertFeatureTreeFolder2(1)”
1 Indicates an empty folder before a selected item.
Now in order to add a folder via API, you need to have something selected. So you can either add a sketch or feature first (can be manually or via API), select that and add the folder. And finally delete that sketch or feature.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeatMgr As SldWorks.FeatureManager
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "There is no active SOLIDWORKS document.", vbExclamation
Exit Sub
End If
Dim docType As Long
docType = swModel.GetType
If docType <> swDocPART And docType <> swDocASSEMBLY Then
MsgBox "The macro works only with a Part or Assembly.", vbExclamation
Exit Sub
End If
Set swFeatMgr = swModel.FeatureManager
Dim folderNames As Variant
folderNames = Array("Body", "Ws", "Holes", "Studs", "Taps", "Brs", "Trims", "Locs", "Ens")
Dim i As Long
For i = LBound(folderNames) To UBound(folderNames)
Call AddEmptyFolderIfMissing(CStr(folderNames(i)))
Next i
swModel.ClearSelection2 True
swModel.EditRebuild3
MsgBox "Done. Folders added.", vbInformation
End Sub
Private Sub AddEmptyFolderIfMissing(ByVal folderName As String)
If FolderExists(folderName) = True Then Exit Sub
Dim swFirstFeat As SldWorks.Feature
Set swFirstFeat = GetFirstUsableTopFeature()
If swFirstFeat Is Nothing Then
MsgBox "Unable to determine insertion location for folder:" & folderName, vbExclamation
Exit Sub
End If
swModel.ClearSelection2 True
Dim ok As Boolean
ok = swFirstFeat.Select2(False, -1)
If ok = False Then
MsgBox "Unable to select feature to insert folder:" & folderName, vbExclamation
Exit Sub
End If
Dim swNewFolder As SldWorks.Feature
Set swNewFolder = swFeatMgr.InsertFeatureTreeFolder2(1)
swModel.ClearSelection2 True
If swNewFolder Is Nothing Then
MsgBox "Failed to create folder: " & folderName, vbExclamation
Exit Sub
End If
On Error Resume Next
swNewFolder.Name = folderName
On Error GoTo 0
End Sub
Private Function GetFirstUsableTopFeature() As SldWorks.Feature
Dim i As Long
Dim swFeat As SldWorks.Feature
Dim featName As String
Dim featType As String
Set GetFirstUsableTopFeature = Nothing
For i = 0 To swModel.GetFeatureCount - 1
Set swFeat = swModel.FeatureByPositionReverse(i)
If Not swFeat Is Nothing Then
featName = ""
featType = ""
On Error Resume Next
featName = swFeat.Name
featType = swFeat.GetTypeName2
On Error GoTo 0
' Find Origin and paste it after it.
If InStr(featType, "Origin") <> 0 Then
Set GetFirstUsableTopFeature = swModel.FeatureByPositionReverse(i - 1)
Exit Function
End If
End If
Next i
End Function
Private Function FolderExists(ByVal folderName As String) As Boolean
FolderExists = False
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
Do While Not swFeat Is Nothing
On Error Resume Next
If StrComp(swFeat.Name, folderName, vbTextCompare) = 0 Then
If LCase$(swFeat.GetTypeName2) = LCase$("FtrFolder") Then
FolderExists = True
Exit Function
End If
End If
On Error GoTo 0
Set swFeat = swFeat.GetNextFeature
Loop
End Function
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeatMgr As SldWorks.FeatureManager
Dim swFeat As SldWorks.Feature
Dim swSketchFeat As SldWorks.Feature
Dim folderNames As Variant
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "No active model open.", vbCritical
Exit Sub
End If
Set swFeatMgr = swModel.FeatureManager
swModel.Extension.SelectByID2 "Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0
swModel.SketchManager.InsertSketch True
swModel.SketchManager.CreateCornerRectangle 0, 0, 0, 0.1, 0.1, 0
swModel.SketchManager.InsertSketch True
Set swSketchFeat = swModel.FeatureByPositionReverse(0)
swSketchFeat.Select2 False, 1
folderNames = Array("Body", "Ws", "Holes", "Studs", "Taps", "Brs", "Trims", "Locs", "Ens")
For i = UBound(folderNames) To LBound(folderNames) Step -1
Set swFeat = swFeatMgr.InsertFeatureTreeFolder2(1)
If Not swFeat Is Nothing Then
swFeat.Name = folderNames(i)
Else
MsgBox "Folder creation failed on: " & folderNames(i)
Exit Sub
End If
Next i
swModel.ClearSelection2 True
swSketchFeat.Select2 False, 1
swModel.EditDelete
End Sub
It basically adds the folder before the selected feature. So when a new folder is created, it is selected by default, and next folder will be added before it. Hence you need to add the folders in reverse.
For i = UBound(folderNames) To LBound(folderNames) Step -1
Interesting. Since I am not a macro running guy my thoughts on how to do this go to setting up a template that will already have empty folders in them.
Your suggested code adds the necessary folders, but has two problems.
1- It always add the folders at the top of the feature tree (bellow Origin), regardless of which feature is selected.
2- If I’m in an assembly and select a feature inside a component, the folders are added to the assembly and not to the selected component.
My code, and later corrected by @gupta9665 adds the folder above the selected feature, and if in an assembly, they are added to the selected component.
Yes, that’s what I’m doing now. Our recent template has the folders. But when I need to work on an old file, that doesn’t contain the folders, I have to add them manually. A macro needs a click to add all.
@gupta9665 A note about the version you suggested:
1- If I open a part and run your macro, a sketch is added to the bottom of the feature tree, then I receive an error saying : Folder creation failed on: Ens
The code stops and nothing’s added
2- If I open an assembly that contains several components, a sketch is added to the bottom of the feature tree, all folders are added, then I receive a message that if I want to delete the sketch.
I think it’s a little bit over kill.
Million Thanks for all your efforts and help.
With your help, I have a perfect working macro that exactly does what I was trying to achieve.