SolidWorks*Excel+VBA-更名第一步,先扒拉装配关系

Sub SearchLink()Dim swModelDoc As ModelDoc2, swModelDocNm As StringDim ReturnVal(), posn As Long, fsNames As Variant, AllModelNmDic As DictionaryDim i As Integer, fsNm As String, nmtmp As String    If myselcondi Then        posn = Selarray(1): SetGolDic        With ThisWorkbook.ActiveSheet            If UCase(.Cells(posn, PropTitDicA("扩展名"))) <> ".SLDASM" Then                MsgBox "未选择装配,程序结束!", vbExclamation, "不正经的机械仙人"                Exit Sub            End If            fsNm = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) & .Cells(posn, PropTitDicA("扩展名"))        End With        ReturnVal = OpenDsFiles_next("model", posn)        If VarType(ReturnVal(0)) <> vbEmpty Then            ThisWorkbook.Sheets("SW2 装配关系").Activate            Set swModelDoc = ReturnVal(0): swModelDocNm = swModelDoc.GetPathName            Set AllModelNmDic = CreateObject("Scripting.Dictionary")            Application.StatusBar = "正在搜索:" & swModelDocNm            With ThisWorkbook.ActiveSheet                .AutoFilter.ShowAllData: .Range("A3:Z10000").ClearContents                .Cells(3, PropTitDicA("文件全名")) = swModelDocNm                .Cells(3, PropTitDicA("文件位置")) = Left(swModelDocNm, InStrRev(swModelDocNm, "\") - 1)                .Cells(3, PropTitDicA("SW模型文件名")) = Split(Dir(swModelDocNm, vbNormal), ".")(0)                .Cells(3, PropTitDicA("扩展名")) = "." & UCase(Split(Dir(swModelDocNm, vbNormal), ".")(1))                .Cells(3, PropTitDicA("新文件位置")) = .Cells(3, PropTitDicA("文件位置"))                .Cells(3, PropTitDicA("新SW模型名称")) = .Cells(3, PropTitDicA("SW模型文件名"))            End With            AllModelNmDic.Add swModelDocNm, ""            ExpAsmModel swModelDoc, 3, 4, AllModelNmDic '递归搜索            Set AllModelNmDic = Nothing            Application.StatusBar = False            swApp.QuitDoc swModelDocNm            MsgBox fsNm & "所有装配关系已搜索完毕!", vbInformation, "不正经的机械仙人"        Else            MsgBox fsNm & Chr(13) & "打开失败!", vbExclamation, "不正经的机械仙人"        End If    Else        MsgBox "未选择正确行,程序结束!", vbExclamation, "不正经的机械仙人"    End IfEnd SubSub ExpAsmModel(ParaModel As ModelDoc2, i As Long, j As Long, AllModelNmDic As Dictionary) '递归展开装配模型Dim Comps As Variant, Comp As Variant, ChiModel As ModelDoc2Dim ModelNmDic As Dictionary, ChiModelNm As String    ParaModel.ResolveAllLightWeightComponents False    Comps = ParaModel.GetComponents(True)    Set ModelNmDic = CreateObject("Scripting.Dictionary")    With ThisWorkbook.ActiveSheet        For Each Comp In Comps            If Comp.IsSuppressed Then                Comp.SetSuppression2 swComponentFullyResolved '第一次解除压缩                Comp.SetSuppression2 swComponentFullyResolved '第二次解除轻化            End If            Set ChiModel = Comp.GetModelDoc2: ChiModelNm = ChiModel.GetPathName            If Not ModelNmDic.Exists(ChiModelNm) Then '单个装配内，不重复搜索子阶                Application.StatusBar = "正在搜索:" & ChiModelNm                ModelNmDic.Add ChiModelNm, ""                .Cells(i, PropTitDicA("父阶")) = ParaModel.GetPathName                .Cells(i, PropTitDicA("子阶")) = ChiModelNm                i = i + 1            End If            If Not AllModelNmDic.Exists(ChiModelNm) Then '所有文件全名，全局唯一                 AllModelNmDic.Add ChiModelNm, ""                .Cells(j, PropTitDicA("文件全名")) = ChiModelNm                .Cells(j, PropTitDicA("文件位置")) = Left(ChiModelNm, InStrRev(ChiModelNm, "\") - 1)                .Cells(j, PropTitDicA("SW模型文件名")) = Split(Dir(ChiModelNm, vbNormal), ".")(0)                .Cells(j, PropTitDicA("扩展名")) = "." & UCase(Split(Dir(ChiModelNm, vbNormal), ".")(1))                .Cells(j, PropTitDicA("新文件位置")) = .Cells(j, PropTitDicA("文件位置"))                .Cells(j, PropTitDicA("新SW模型名称")) = .Cells(j, PropTitDicA("SW模型文件名"))                j = j + 1                If ChiModel.GetType = swDocASSEMBLY Then ExpAsmModel ChiModel, i, j, AllModelNmDic            End If        Next    End With    Set ModelNmDic = Nothing    Set Comp = Nothing    Set Comps = Nothing    Set ChiModel = Nothing    Set ParaModel = NothingEnd Sub