Sub RepSwDrw() '替换工程图图框Dim swApp As SldWorks.SldWorks, DrwPath As String, DrwTemplate As StringDim SwErr As Long, ShtPropVal, SwDrw As DrawingDocDim k As Integer, posn As Long, Results As StringOn Error Resume Next Set swApp = GetObject(, "SldWorks.Application") If swApp Is Nothing Then MsgBox "请先打开SolidWorks!", vbExclamation, "不正经的机械仙人" Exit Sub End If DrwTemplate = ThisWorkbook.Sheets("SW0 参数设置").Range("D4").Value & "\" & _ ThisWorkbook.Sheets("SW0 参数设置").Range("C4").Value With ThisWorkbook.ActiveSheet If myselcondi Then swApp.CloseAllDocuments (True) For k = 1 To Selnumber ProcessBarUpdater k, Selnumber, "正在替换图框：", "共" & Selnumber & "个，第" & k & "个 ..." posn = Selarray(k) DrwPath = .Cells(posn, 2) & "\" & .Cells(posn, 3) & ".SLDDRW" If Dir(DrwPath) = "" Then Results = "无工程图!" Else Set SwDrw = swApp.OpenDoc2(DrwPath, swDocDRAWING, False, False, True, SwErr) If SwDrw Is Nothing Then Results = "打开失败!" Else ShtPropVal = SwDrw.GetCurrentSheet.GetProperties2() If SwDrw.SetupSheet3(SwDrw.GetCurrentSheet.GetName, ShtPropVal(0), ShtPropVal(1), ShtPropVal(2), ShtPropVal(3), ShtPropVal(4), DrwTemplate, ShtPropVal(5), ShtPropVal(6)) = False Then Results = "图框替换失败!" Else SwDrw.Save: swApp.QuitDoc DrwPath: Set SwDrw = Nothing Results = "图框已替换!" End If swApp.QuitDoc DrwPath: Set SwDrw = Nothing: Erase ShtPropVal 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
