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.
The working code is what I posted in my first post above, and the correction of one line you suggested.
If a part is opened and a feature is selected : it adds the folders above the selected feature.
If an assembly is opened and a component is selected : it adds the folders above the selected component.
If an assembly is opened and a feature within a component is selected : it adds the folders above the selected feature inside the component.
It works the same for both virtual and externally saved components in an assembly.
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 = UBound(folderNames) To LBound(folderNames) Step -1
' Create folder (type argument = 1 = Feature folder)
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
End Sub
I was trying to keep things as simple as possible for the forum, so I didn’t feel the need to clutter the page with obvious checks.
Assemblies and drawings are configured to display specific customized toolbars. Otherwise, the screen would be cluttered with unnecessary buttons. Now that you mention it, I’ll add this check just to be safe.
During all my tests, I didn’t face any situation where the folders were added but not visible. But if you think it may happen and there’s a possibility, I think I will add this too. Thanks.
To be honest, I don’t know what does this mean and how it can be helpful. When I’m adding a folder via a macro, can the return object be different? Any further explanation, how it may occure or how I can check this is much appreciated.
Of course, this only applies to those who are familiar with the conditions. We are a small company with just a few people using SolidWorks. The goal of this thread was to find a way to simplify OUR daily tasks, not to offer a macro for general use.
I really appreciate your concerns and inputs. And all the time you spent to help.
Million thanks.
Here’s a simple part that triggers the error I mentioned above. I’ve also included a macro based on your suggestion so you can check whether I’ve made a mistake.
In my code I was using FeatureByPositionReverse(0) to select the last created feature. So when you used it for a sheet metal part, it was selecting the flat pattern feature instead of the created sketch. Hence you were getting the error.
So if you change these lines
Set swSketchFeat = swModel.FeatureByPositionReverse(0)
swSketchFeat.Select2 False, 1
to
Set swSketchFeat = swModel.SelectionManager.GetSelectedObject6(1, -1)
it should work.
I also realized that this line swSketchFeat.Select2 False, 1 was not required.
Critical code issues:
Non-critical code issues: