Get Solid Bodies from Cut List Folders and Get Custom Properties Example
(VBA)
This example shows how to get the solid bodies from cut list folders
and how to get the custom properties for the solid bodies.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swPart As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim Indent As Long
Sub GetFeatureCustomProps(thisFeat As SldWorks.Feature)
Dim
CustomPropMgr As SldWorks.CustomPropertyManager
Set
CustomPropMgr = thisFeat.CustomPropertyManager
Dim
vCustomPropNames As Variant
vCustomPropNames
= CustomPropMgr.GetNames
If
Not IsEmpty(vCustomPropNames) Then
Dim
NameFmt As String
NameFmt
= "!" & String(30, "@")
Dim
TypeFmt As String
TypeFmt
= "!" & String(6, "@")
Dim
ValFmt As String
ValFmt
= "!" & String(80, "@")
Dim
ResValFmt As String
ResValFmt
= "!" & String(40, "@")
Debug.Print
String(Indent + 3, " ") & "Cut List Custom Properties
:"
Dim
i As Long
For
i = LBound(vCustomPropNames) To UBound(vCustomPropNames)
Dim
CustomPropName As String
CustomPropName
= vCustomPropNames(i)
Debug.Print
Format(String(Indent + 6, " ") & CustomPropName, NameFmt);
Dim
CustomPropType As Long
CustomPropType
= CustomPropMgr.GetType(CustomPropName)
Dim
CustomPropVal As String
Dim
CustomPropResolvedVal As String
CustomPropMgr.Get2 CustomPropName, CustomPropVal,
CustomPropResolvedVal
Debug.Print
Format(CustomPropVal, ValFmt);
Debug.Print
Format(CustomPropResolvedVal, ResValFmt)
Next
i
End
If
End Sub
Sub DoTheWork(thisFeat As SldWorks.Feature, ParentName
As String)
Static
InBodyFolder As Boolean
Static
BodyFolderType(5) As String
Static
BeenHere As Boolean
Dim
bAllFeatures As Boolean
Dim
bCutListCustomProps As Boolean
If
Not BeenHere Then
BodyFolderType(0)
= "dummy"
BodyFolderType(1)
= "swSolidBodyFolder"
BodyFolderType(2)
= "swSurfaceBodyFolder"
BodyFolderType(3)
= "swBodySubFolder"
BodyFolderType(4)
= "swWeldmentSubFolder"
BodyFolderType(5)
= "swWeldmentCutListFolder"
InBodyFolder
= False
BeenHere
= True
bAllFeatures
= False
bCutListCustomProps
= False
End
If
'Comment
out next line to print information for just BodyFolders
'bAllFeatures
= True 'True to print information about all features
'Comment
out next line if do not want cut list's custom properties
bCutListCustomProps
= True 'True
to print cut list's custom property information
Dim
FeatType As String
FeatType
= thisFeat.GetTypeName
If
(FeatType = "SolidBodyFolder") And (ParentName = "Root
Feature") Then
InBodyFolder
= True
End
If
If
(FeatType <> "SolidBodyFolder") And (ParentName = "Root
Feature") Then
InBodyFolder
= False
End
If
If
(InBodyFolder = False) And (FeatType = "CutListFolder") Then
'Only
consider the CutListFolders that are under the SolidBodyFolder
Exit
Sub 'Skip
the second occurrence of the CutListFolders during the feature traversal
End
If
If
(InBodyFolder = False) And (FeatType = "SubWeldFolder") Then
'Only
consider the SubWeldFolder that are under the SolidBodyFolder
Exit
Sub 'Skip
the second occurrence of the SubWeldFolders during the feature traversal
End
If
Dim
IsBodyFolder As Boolean
If
FeatType = "SolidBodyFolder" Or _
FeatType
= "SurfaceBodyFolder" Or _
FeatType
= "CutListFolder" Or _
FeatType
= "SubWeldFolder" Or _
FeatType
= "SubAtomFolder" _
Then
IsBodyFolder
= True
Else
IsBodyFolder
= False
End
If
Dim
FeatNameFmt As String
FeatNameFmt
= "!" & String(42, "@")
If
(FeatType = "FtrFolder") And (InStr(1, thisFeat.Name, "___EndTag___",
0) > 0) Then 'This
is the folder End Tag
Indent
= Indent - 3
End
If
If
bAllFeatures And (Not IsBodyFolder) Then
Debug.Print
Format(String(Indent, " ") & thisFeat.Name,
FeatNameFmt); Format(FeatType, "!" & String(18, "@"));
Dim
vSuppressed As Variant
vSuppressed
= thisFeat.IsSuppressed2(swThisConfiguration,
Empty)
If
IsEmpty(vSuppressed) Then
Debug.Print
"IsSuppressed2 failed";
Else
Debug.Print
Format(IIf(vSuppressed(0) = False, " ", "Suppressed"),
"!" & String(15, "@"));
End
If
End
If
If
IsBodyFolder Then
Dim
BodyFolder As SldWorks.BodyFolder
Set
BodyFolder = thisFeat.GetSpecificFeature2
Dim
BodyCount As Long
BodyCount
= BodyFolder.GetBodyCount
If
(FeatType = "CutListFolder") And (BodyCount < 1) Then
Exit
Sub 'When
BodyCount = 0, this cut list folder is not displayed in the
'Feature
Manager design Tree, so skip it
Else
Debug.Print
Format(String(Indent, " ") & thisFeat.Name,
FeatNameFmt); Format(FeatType, "!" & String(18, "@"));
vSuppressed
= thisFeat.IsSuppressed2(swThisConfiguration,
Empty)
If
IsEmpty(vSuppressed) Then
Debug.Print
"IsSuppressed2 failed";
Else
Debug.Print
Format(IIf(vSuppressed(0) = False, " ", "Suppressed"),
"!" & String(15, "@"));
End
If
End
If
If
Not bAllFeatures Then
Debug.Print
Format(String(Indent, " ") & thisFeat.Name,
FeatNameFmt); Format(FeatType, "!" & String(18, "@"));
vSuppressed
= thisFeat.IsSuppressed2(swThisConfiguration,
Empty)
If
IsEmpty(vSuppressed) Then
Debug.Print
"IsSuppressed2 failed";
Else
Debug.Print
Format(IIf(vSuppressed(0) = False, " ", "Suppressed"),
"!" & String(15, "@"));
End
If
End
If
Dim
BodyFolderTypeE As Long
BodyFolderTypeE
= BodyFolder.Type
Debug.Print
Format(BodyFolderType(BodyFolderTypeE), "!" & String(28,
"@")); Format(BodyFolderTypeE, "!@@@@");
Debug.Print
Format("Body Count " & BodyCount, "!" & String(15,
"@"))
Dim
vBodies As Variant
vBodies
= BodyFolder.GetBodies
Dim
i As Long
If
Not IsEmpty(vBodies) Then
For
i = LBound(vBodies) To UBound(vBodies)
Dim
Body As SldWorks.Body2
Set
Body = vBodies(i)
Debug.Print
Format(String(Indent + 3, " ") & Body.Name,
"!" & String(32, "@"))
Next
i
End
If
Else
If
bAllFeatures Then
Debug.Print
'Finish off pending print line
End
If
End
If
If
(FeatType = "CutListFolder") Then
If
BodyCount > 0 Then 'When
BodyCount = 0, this cut list folder is not displayed
'in
the FeatureManager design tree, so skip it
If
bCutListCustomProps Then
GetFeatureCustomProps
thisFeat 'Comment out this line if you do not want to
'print
the cut list folder's custom properties
End
If
End
If
End
If
If
(FeatType = "FtrFolder") And (InStr(1, thisFeat.Name, "___EndTag___",
0) < 1) Then 'This
is the folder start marker
Indent
= Indent + 3
End
If
End Sub
Sub TraverseFeatures(thisFeat As SldWorks.Feature, isTopLevel
As Boolean, ParentName As String)
Dim
curFeat As SldWorks.Feature
Set
curFeat = thisFeat
Indent
= Indent + 3
While
Not curFeat Is Nothing
DoTheWork
curFeat, ParentName 'Do the thing that we are doing this feature traversal
for
Dim
subfeat As SldWorks.Feature
Set
subfeat = curFeat.GetFirstSubFeature
While
Not subfeat Is Nothing
TraverseFeatures
subfeat, False, curFeat.Name
Dim
nextSubFeat As SldWorks.Feature
Set
nextSubFeat = subfeat.GetNextSubFeature
Set
subfeat = nextSubFeat
Set
nextSubFeat = Nothing
Wend
Set
subfeat = Nothing
Dim
nextFeat As SldWorks.Feature
If
isTopLevel Then
Set
nextFeat = curFeat.GetNextFeature
Else
Set
nextFeat = Nothing
End
If
Set
curFeat = nextFeat
Set
nextFeat = Nothing
Wend
Indent
= Indent - 3
End Sub
Sub main()
Set
swApp = Application.SldWorks
Set
swPart = swApp.ActiveDoc
Debug.Print
"File = " & swPart.GetPathName
Dim
ConfigName As String
ConfigName
= swPart.ConfigurationManager.ActiveConfiguration.Name
Debug.Print
"Active Configuration Name = " & ConfigName
Indent
= -3
Set
swFeat = swPart.FirstFeature
TraverseFeatures
swFeat, True, "Root Feature"
End Sub