SolidWorks*Excel+VBA-强势插入

Sub InsertModel() '插入零部件Dim SwApp As SldWorks.SldWorks, SwCurModel As ModelDoc2Dim OpennedModel As ModelDoc2, Openned As Boolean, SwErr As LongDim AddModelName As String, AddResult As BooleanDim k As Integer, Posn As LongOn Error Resume Next    Set SwApp = GetObject(, "SldWorks.Application")    If SwApp Is Nothing Then        MsgBox "请先打开SolidWorks！", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    Set SwCurModel = SwApp.ActiveDoc    If SwCurModel Is Nothing Then        MsgBox "未打开任何SW文件！", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    If SwCurModel.GetType <> swDocASSEMBLY Then        MsgBox "当前不是SW装配文件！", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    If myselcondi Then        With ThisWorkbook.ActiveSheet            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在插入模型：", "共" & Selnumber & "个，第" & k & "个 ..."                Posn = Selarray(k)                AddModelName = .Cells(Posn, 2) & "\" & .Cells(Posn, 3) & .Cells(Posn, 4)                Set OpennedModel = SwApp.GetOpenDocument(AddModelName)                If Not OpennedModel Is Nothing Then                    Set OpennedModel = Nothing: Openned = True                End If                If UCase(.Cells(Posn, 4)) = ".SLDPRT" Then                    If Not Openned Then SwApp.OpenDoc2 AddModelName, swDocPART, False, False, True, SwErr                ElseIf UCase(.Cells(Posn, 3) & .Cells(Posn, 4)) = UCase(SwCurModel.GetTitle) Then                    GoTo InsMine '同名装配，不允许插入自己，无关乎路径                Else                    If Not Openned Then SwApp.OpenDoc2 AddModelName, swDocASSEMBLY, False, False, True, SwErr                End If                AddResult = SwCurModel.AddComponent(AddModelName, 0, 0, 0)                If AddResult Then                    .Cells(Posn, 1) = "模型插入√"                    AddResult = False                ElseInsMine:            .Cells(Posn, 1) = "插入失败！"                End If                If Openned Then                    Openned = False                Else                    SwApp.QuitDoc AddModelName                End If            Next        End With    Else        MsgBox "未选择正确行，程序结束！", vbExclamation, "不正经的机械仙人"    End If    Err.Clear    Set SwCurModel = Nothing    Set SwApp = Nothing    Application.StatusBar = FalseEnd Sub