SolidWorks*Excel+VBA-找尺寸

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