SolidWorks*Excel+VBA-批量工程图

Sub NewSwDrw() '生成工程图Dim swApp As SldWorks.SldWorks, FullModelPath As String, DrwTemplate As StringDim OpennedModel As ModelDoc2, PartModel As PartDoc, SwErr As Long, PropVal As StringDim k As Integer, posn As Long, SwDrw As DrawingDocDim Results As String, Suffix(), ModelType(), OpenVal As LongOn Error Resume Next    Set swApp = GetObject(, "SldWorks.Application")    If swApp Is Nothing Then        MsgBox "请先打开SolidWorks!", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    Suffix = Array(".SLDPRT", ".SLDASM"): ModelType = Array(swDocPART, swDocASSEMBLY)    DrwTemplate = ThisWorkbook.Sheets("SW0 参数设置").Range("D3").Value & "\" & _                  ThisWorkbook.Sheets("SW0 参数设置").Range("C3").Value    With ThisWorkbook.ActiveSheet        If myselcondi Then            swApp.CloseAllDocuments (True)            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在生成工程图：", "共" & Selnumber & "个，第" & k & "个 ..."                posn = Selarray(k)                If Dir(.Cells(posn, 2) & "\" & .Cells(posn, 3) & ".SLDDRW") <> "" Then                    Results = "已有同名工程图!"                Else                    FullModelPath = .Cells(posn, 2) & "\" & .Cells(posn, 3) & .Cells(posn, 4)                    OpenVal = ModelType(WorksheetFunction.Match(UCase(.Cells(posn, 4)), Suffix, 0) - 1)                    Set OpennedModel = swApp.OpenDoc2(FullModelPath, OpenVal, False, False, True, SwErr)                    If OpennedModel Is Nothing Then                        Results = "模型打开失败!"                    Else                        Set SwDrw = swApp.NewDocument(DrwTemplate, 0, 0, 0)                        If SwDrw Is Nothing Then                            Results = "工程图生成失败!"                        Else                            SwDrw.InsertModelInPredefinedView FullModelPath                            SwDrw.SaveAs2 .Cells(posn, 2) & "\" & .Cells(posn, 3) & ".SLDDRW", swSaveAsCurrentVersion, False, True                            swApp.QuitDoc .Cells(posn, 2) & "\" & .Cells(posn, 3) & ".SLDDRW"                            Set SwDrw = Nothing                            Results = "已生成工程图!"                        End If                        swApp.QuitDoc FullModelPath: Set OpennedModel = Nothing                    End If                End If                .Cells(posn, 1) = Results: Results = ""            Next        Else            MsgBox "未选择正确行，程序结束!", vbExclamation, "不正经的机械仙人"        End If    End With    Err.Clear    Set swApp = Nothing    Application.StatusBar = FalseEnd Sub