【求助】装配图中的零件序号排列 - iCAx开思网

Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As ModelDoc2
Dim swAssyDoc As AssemblyDoc
Dim selMgr As SelectionMgr
Dim boolstatus As Boolean
Dim components As Variant
Dim swComp As Component2
Dim nComponents As Integer
Dim sArray() As String
Dim iArray() As Integer
Dim I As Integer
Dim x As Integer
Dim y As Integer
Dim sTemp As String
Dim iTemp As Integer
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
'检查是否有效的装配体文档打开
If Part Is Nothing Then
swApp.SendMsgToUser "当前没有任何文档打开，该程序必须在装配体中运行！"
Exit Sub
ElseIf Part.GetType <> swDocASSEMBLY Then
swApp.SendMsgToUser "当前打开的文档不是一个装配体，请打开装配体后再试！"
Exit Sub
End If
Set swAssyDoc = Part
Set selMgr = Part.SelectionManager
' 获得所有顶级零部件
components = swAssyDoc.GetComponents(True)
' 获取零部件数组的上边界
nComponents = UBound(components)
ReDim sArray(nComponents)
ReDim iArray(nComponents)
' 增加零部件名称以及数组索引
For I = 0 To nComponents
Set swComp = components(I)
sArray(I) = swComp.Name2
iArray(I) = I
Next I
' 对数组进行冒泡排序
For x = 0 To (nComponents - 1)
For y = (x + 1) To nComponents
If sArray(x) > sArray(y) Then
sTemp = sArray(x)
iTemp = iArray(x)
sArray(x) = sArray(y)
iArray(x) = iArray(y)
sArray(y) = sTemp
iArray(y) = iTemp
End If
Next y
Next x
' 按照相反的顺序对零部件重新排序
For I = (nComponents - 1) To 0 Step -1
' Debug.Print components(iArray(i)).Name2 & " - " & components(iArray(i + 1)).Name2
boolstatus = swAssyDoc.ReorderComponents(components(iArray(I)), components(iArray(I + 1)), swReorderComponents_Before)
Next I
End Sub

复制代码