solidworks设计树特征遍历 - iCAx开思网

' Preconditions: Part or assembly is open 条件:开启零件或装配体.
' Postconditions: None 结果:无----实现自动退回到每个特征,并作延迟
' NOTES: The delay between steps is set to 1 second.注意:每步延迟设置一钞
'---------------------------------
Option Explicit
Public Enum swDocumentTypes_e '文件类型常数
swDocNONE = 0
swDocPART = 1
swDocASSEMBLY = 2
swDocDRAWING = 3
End Enum
Public Enum swMoveRollbackBarTo_e '退回到目标常数
swMoveRollbackBarToEnd = 1
swMoveRollbackBarToPreviousPosition = 2
swMoveRollbackBarToBeforeFeature = 3
swMoveRollbackBarToAfterFeature = 4
End Enum
Sub main()
' Delay in seconds 延迟时间秒
Const DELAY As Single = 1#
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swAssy As SldWorks.AssemblyDoc
Dim swFeatMgr As SldWorks.FeatureManager
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFeat As SldWorks.Feature
Dim vFeatFace As Variant
Dim swFace As SldWorks.Face2
Dim sFeatName() As String
Dim sNow As Single
Dim nDocType As Long
Dim i As Long
Dim j As Long
Dim bRet As Boolean
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swFeatMgr = swModel.FeatureManager
Set swFeat = swModel.FirstFeature
nDocType = swModel.GetType
Select Case nDocType
Case swDocPART
Set swPart = swModel
Case swDocASSEMBLY
Set swAssy = swModel
End Select
'以下获取特征名称
ReDim sFeatName(0)
Do While Not swFeat Is Nothing
sFeatName(UBound(sFeatName)) = swFeat.Name
ReDim Preserve sFeatName(UBound(sFeatName) + 1)
Set swFeat = swFeat.GetNextFeature
Loop
' Loop over-allocates array by 1, so remove last (empty) entry循环数超出数组数为1,所以删除最后(空)项
ReDim Preserve sFeatName(UBound(sFeatName) - 1)
' Playback each feature in the FeatureManager design tree 在设计特征树中退回每一步
For i = 0 To UBound(sFeatName)
Debug.Print sFeatName(i)
bRet = swFeatMgr.EditRollback(swMoveRollbackBarToAfterFeature, sFeatName(i)) '退回命令
' Do not assert because you may be trying to roll back or roll forward
' to a feature that cannot be rolled back or forward to; for example,
' the Lighting or Annotations folder 灯光或注释文件夹
'Debug.Assert bRet
' Remove any previous highlights 去除原来的高亮
swModel.GraphicsRedraw2
' Highlight feature if it has any geometry 高亮相关的几何体
Select Case nDocType
Case swDocPART
Set swFeat = swPart.FeatureByName(sFeatName(i))
Case swDocASSEMBLY
Set swFeat = swAssy.FeatureByName(sFeatName(i))
End Select
vFeatFace = swFeat.GetFaces '获取特征相关面
If Not IsEmpty(vFeatFace) Then
For j = 0 To UBound(vFeatFace)
Set swFace = vFeatFace(j)
swFace.Highlight True '高亮相关面
Next j
End If
' Only pause if rollback is successful '在退回成功时延迟暂停
If bRet Then
sNow = Timer
While sNow + DELAY > Timer
' Allow SolidWorks to refresh screen 允计刷屏
DoEvents
Wend
End If
Next i
' Remove highlight from last feature 为下个特征去除高亮
swModel.GraphicsRedraw2
End Sub

复制代码

Sub main()
Dim PathName As String
Dim SheetName() As String
Dim ConfigName As String
Dim SplittedPathName() As String
Dim ModelName As String
On Error Resume Next
Set swApp = Application.SldWorks
Set drawing = swApp.ActiveDoc
If drawing Is Nothing Then
MsgBox "请打开图纸"
Exit Sub
End If
If drawing.GetType <> 3 Then Exit Sub
SheetName = drawing.GetSheetNames
SheetCount = drawing.GetSheetCount
'For i = 0 To SheetCount - 1
' drawing.ActivateSheet SheetName(i)
' Set swSheet = drawing.GetCurrentSheet
' swSheet.SetName "[ DISCUZ_CODE_0 ]quot; & i
'Next
SheetName = drawing.GetSheetNames
For i = 0 To SheetCount - 1 '更改图纸名称形式为图号+配置+N个"," 方便后面重新命名
drawing.ActivateSheet SheetName(i)
Set swView = drawing.GetFirstView.GetNextView
PathName = swView.GetReferencedModelName
ConfigName = swView.ReferencedConfiguration
SplittedPathName = Split(PathName, "")
ModelName = SplittedPathName(UBound(SplittedPathName))
ModelName = Left(ModelName, Len(ModelName) - 7)
Set swSheet = drawing.GetCurrentSheet
If ConfigName = "Default" Or ConfigName = "默认" Or ConfigName = "預設" Then
thissheetname = ModelName
Else
thissheetname = ModelName & ConfigName
End If
swSheet.SetName thissheetname
CurrentSheetName = swSheet.GetName
c = 1
While CurrentSheetName <> thissheetname
thissheetname = thissheetname & ","
swSheet.SetName thissheetname
CurrentSheetName = swSheet.GetName
c = c + 1
Wend
Next
SheetName = drawing.GetSheetNames
For i = 0 To SheetCount - 1 '更改同配置图纸形式为图号+配置+（第几张图纸）
drawing.ActivateSheet SheetName(i)
Set swView = drawing.GetFirstView.GetNextView
SheetName = drawing.GetSheetNames
Temp = 1
If Right(SheetName(i), 1) = "," Then
While Right(SheetName(i), 1) = ","
SheetName(i) = Left(SheetName(i), Len(SheetName(i)) - 1)
Temp = Temp + 1
Wend
Set swSheet = drawing.GetCurrentSheet
swSheet.SetName SheetName(i) & "(" & Temp & ")"
Else
Set swSheet = drawing.GetCurrentSheet
swSheet.SetName SheetName(i) & "(" & Temp & ")"
End If
Next
SheetName = drawing.GetSheetNames
drawing.ActivateSheet SheetName(0)
End Sub

复制代码