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
