Sub GetSwFilesSizes() '获取模型尺寸数据Dim swApp As SldWorks.SldWorks, FullModelPath As StringDim OpennedModel As ModelDoc2, SwErr As LongDim k As Integer, Posn As Long, Pbox As VariantDim dx As Double, dy As Double, dz As Double'On Error Resume Next Set swApp = GetObject(, "SldWorks.Application") If swApp Is Nothing Then MsgBox "请先打开SolidWorks！", vbExclamation, "不正经的机械仙人" Exit Sub End If If myselcondi Then With ThisWorkbook.ActiveSheet swApp.CloseAllDocuments (True) For k = 1 To Selnumber ProcessBarUpdater k, Selnumber, "正在获取尺寸：", "共" & Selnumber & "个，第" & k & "个 ..." Posn = Selarray(k) If UCase(.Cells(Posn, 4)) = ".SLDPRT" Then FullModelPath = .Cells(Posn, 2) & "\" & .Cells(Posn, 3) & .Cells(Posn, 4) Set OpennedModel = swApp.OpenDoc2(FullModelPath, swDocPART, True, False, True, SwErr) If OpennedModel Is Nothing Then .Cells(Posn, 1) = "获取失败！" Else Pbox = OpennedModel.GetPartBox(False) dx = Round(Pbox(3) - Pbox(0), 2) dy = Round(Pbox(4) - Pbox(1), 2) dz = Round(Pbox(5) - Pbox(2), 2) Erase Pbox .Cells(Posn, 7) = dx & "*" & dy & "*" & dz Set OpennedModel = Nothing swApp.QuitDoc FullModelPath .Cells(Posn, 1) = "尺寸√" End If End If Next End With Else MsgBox "未选择正确行，程序结束！", vbExclamation, "不正经的机械仙人" End If Err.Clear Set swApp = Nothing Application.StatusBar = FalseEnd Sub
