|
|
Option Explicit
Sub BlankSketchFeature(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swFeat As SldWorks.Feature)
Dim bRet As Boolean
If "ProfileFeature" = swFeat.GetTypeName Then
bRet = swFeat.Select2(False, 0): Debug.Assert bRet
swModel.BlankSketch '隐藏草图
End If
End Sub
Sub TraverseFeatureFeatures(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swFeat As SldWorks.Feature, nLevel As Long)
Dim swSubFeat As SldWorks.Feature
Dim swSubSubFeat As SldWorks.Feature
Dim swSubSubSubFeat As SldWorks.Feature
Dim sPadStr As String
Dim i As Long
For i = 0 To nLevel
sPadStr = sPadStr + " "
Next i
Dim bRet As Boolean
If "Annotations" <> swFeat.Name Then
bRet = swFeat.Select2(True, 0): Debug.Assert bRet
End If
While Not swFeat Is Nothing
Debug.Print sPadStr + swFeat.Name + " [" + swFeat.GetTypeName + "]"
BlankSketchFeature swApp, swModel, swFeat
Set swSubFeat = swFeat.GetFirstSubFeature
While Not swSubFeat Is Nothing
Debug.Print sPadStr + " " + swSubFeat.Name + " [" + swSubFeat.GetTypeName + "]"
BlankSketchFeature swApp, swModel, swSubFeat
Set swSubSubFeat = swSubFeat.GetFirstSubFeature
While Not swSubSubFeat Is Nothing
Debug.Print sPadStr + " " + swSubSubFeat.Name + " [" + swSubSubFeat.GetTypeName + "]"
BlankSketchFeature swApp, swModel, swSubSubFeat
Set swSubSubSubFeat = swSubFeat.GetFirstSubFeature
While Not swSubSubSubFeat Is Nothing
Debug.Print sPadStr + " " + swSubSubSubFeat.Name + " [" + swSubSubSubFeat.GetTypeName + "]"
BlankSketchFeature swApp, swModel, swSubSubSubFeat
Set swSubSubSubFeat = swSubSubSubFeat.GetNextSubFeature()
Wend
Set swSubSubFeat = swSubSubFeat.GetNextSubFeature()
Wend
Set swSubFeat = swSubFeat.GetNextSubFeature()
Wend
Set swFeat = swFeat.GetNextFeature
Wend
End Sub
Sub TraverseComponentFeatures(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swComp As SldWorks.Component2, nLevel As Long)
Dim swFeat As SldWorks.Feature
Set swFeat = swComp.FirstFeature
TraverseFeatureFeatures swApp, swModel, swFeat, nLevel
End Sub
Sub TraverseComponent(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swComp As SldWorks.Component2, nLevel As Long)
Dim vChildComp As Variant
Dim swChildComp As SldWorks.Component2
Dim swCompConfig As SldWorks.Configuration
Dim sPadStr As String
Dim i As Long
For i = 0 To nLevel - 1
sPadStr = sPadStr + " "
Next i
vChildComp = swComp.GetChildren
For i = 0 To UBound(vChildComp)
Set swChildComp = vChildComp(i)
Debug.Print sPadStr & "+" & swChildComp.Name2 & " <" & swChildComp.ReferencedConfiguration & ">"
TraverseComponentFeatures swApp, swModel, swChildComp, nLevel
TraverseComponent swApp, swModel, swChildComp, nLevel + 1
Next i
End Sub
Sub TraverseModelFeatures(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, nLevel As Long)
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
TraverseFeatureFeatures swApp, swModel, swFeat, nLevel
End Sub
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim nStart As Long
Dim bRet As Boolean
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(True)
nStart = Timer
TraverseModelFeatures swApp, swModel, 1 '零件
TraverseComponent swApp, swModel, swRootComp, 1 '装配体
End Sub
|
|
[复制链接]
楼主
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
转播
教程|习题|模型|技巧
点赞
拍砖
发表于 2021-8-27 08:39:59
鲁公网安备 37028502190335号