SolidWorks*Excel+VBA-尺寸?材质?属性?单拉一个算咋回事,齐活!

Sub GetSwModelInf(Stype As String) '获取模型信息，尺寸，材质，自定义属性Dim swApp As SldWorks.SldWorks, FullModelPath As StringDim OpennedModel As ModelDoc2, PartModel As PartDoc, SwErr As Long, PropVal As StringDim k As Integer, posn As Long, Pbox As Variant, dx As Double, dy As Double, dz As DoubleDim Sizes As String, ModelMat As String, ModelCode As String, ModelName As StringDim Results As String, SizeResult As String, MatResult As String, PropResult As String, StatusMsg As String, AsmMsg As StringDim StypeArr(), MsgArr(), 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    StypeArr = Array("SizeAndMat", "Mat", "prop"): MsgArr = Array("尺寸/材质", "材质", "属性")    Suffix = Array(".SLDPRT", ".SLDASM"): ModelType = Array(swDocPART, swDocASSEMBLY)    StatusMsg = MsgArr(WorksheetFunction.Match(Stype, StypeArr, 0) - 1)    With ThisWorkbook.ActiveSheet        If myselcondi Then            swApp.CloseAllDocuments (True)            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在提取" & StatusMsg & "：", "共" & Selnumber & "个，第" & k & "个 ..."                posn = Selarray(k)                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                    Select Case Stype                    Case "SizeAndMat"                        If OpenVal = swDocPART Then                            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)                            Sizes = dx & "*" & dy & "*" & dz: Erase Pbox                        Else                            OpennedModel.Extension.CustomPropertyManager("").Get2 "外型尺寸", PropVal, Sizes                            AsmMsg = "装配:"                        End If                        If (dx = 0 And dy = 0 And dz = 0) Or Sizes = "" Then                            SizeResult = "无尺寸;"                            Sizes = ""                        ElseIf Sizes = .Cells(posn, 7) Then                            SizeResult = "尺寸未改;"                        Else                            SizeResult = "新尺寸;"                        End If                        .Cells(posn, 7) = Sizes: Sizes = ""                        GoTo GetNext                    Case "Mat"GetNext:                If OpenVal = swDocPART Then                            Set PartModel = OpennedModel                            ModelMat = PartModel.GetMaterialPropertyName2("", "")                            Set PartModel = Nothing                        Else                            OpennedModel.Extension.CustomPropertyManager("").Get2 "材料", PropVal, ModelMat                            AsmMsg = "装配:"                        End If                        If ModelMat = "" Then                            MatResult = "无材质;"                        ElseIf ModelMat = .Cells(posn, 11) Then                            MatResult = "材质未改;"                        Else                            MatResult = "新材质;"                        End If                        .Cells(posn, 11) = ModelMat: ModelMat = ""                    Case "prop"                        OpennedModel.Extension.CustomPropertyManager("").Get2 "外型尺寸", PropVal, Sizes                        OpennedModel.Extension.CustomPropertyManager("").Get2 "图号", PropVal, ModelCode                        OpennedModel.Extension.CustomPropertyManager("").Get2 "图名", PropVal, ModelName                        If .Cells(posn, 7) <> Sizes Then PropResult = "尺寸;"                        If .Cells(posn, 12) <> ModelCode Then PropResult = PropResult & "图号;"                        If .Cells(posn, 13) <> ModelName Then PropResult = PropResult & "图名;"                        '...其余属性依次拓展                        If PropResult = "" Then PropResult = "属性未改;"                        .Cells(posn, 7) = Sizes: Sizes = ""                        .Cells(posn, 12) = ModelCode: ModelCode = ""                        .Cells(posn, 13) = ModelName: ModelName = ""                        GoTo GetNext                    End Select                    Set OpennedModel = Nothing: swApp.QuitDoc FullModelPath                    Results = AsmMsg & SizeResult & MatResult & PropResult                    AsmMsg = "": SizeResult = "": MatResult = "": PropResult = ""                End If                .Cells(posn, 1) = Results: Results = ""            Next        Else            MsgBox "未选择正确行，程序结束!", vbExclamation, "不正经的机械仙人"        End If    End With    Err.Clear    Set swApp = Nothing    Application.StatusBar = FalseEnd SubSub SetSwModelInf(Stype As String) '设置模型信息，尺寸，材质，自定义属性Dim swApp As SldWorks.SldWorks, FullModelPath As StringDim MatsDb As StringDim OpennedModel As ModelDoc2, PartModel As PartDoc, SwErr As Long, PropVal As StringDim k As Integer, posn As LongDim Sizes As String, ModelMat As String, ModelCode As String, ModelName As StringDim Results As String, MatResult As String, PropResult As String, StatusMsg As String, AsmMsg As StringDim StypeArr(), MsgArr(), 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    StypeArr = Array("Mat", "prop"): MsgArr = Array("材质", "属性")    Suffix = Array(".SLDPRT", ".SLDASM"): ModelType = Array(swDocPART, swDocASSEMBLY)    StatusMsg = MsgArr(WorksheetFunction.Match(Stype, StypeArr, 0) - 1)    MatsDb = ThisWorkbook.Sheets("SW0 参数设置").Range("C2").Value    With ThisWorkbook.ActiveSheet        If myselcondi Then            swApp.CloseAllDocuments (True)            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在设置" & StatusMsg & "：", "共" & Selnumber & "个，第" & k & "个 ..."                posn = Selarray(k)                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                    Select Case Stype                    Case "Mat"SetNext:                If OpenVal = swDocPART Then                            Set PartModel = OpennedModel                            ModelMat = PartModel.GetMaterialPropertyName2("", "")                        Else                            OpennedModel.Extension.CustomPropertyManager("").Get2 "材料", PropVal, ModelMat                            AsmMsg = "装配:"                        End If                        If ModelMat = .Cells(posn, 11) Then                            MatResult = "材质未改;"                        Else                            If OpenVal = swDocPART Then                                If PartModel.GetMaterialPropertyName2("", "") <> .Cells(posn, 11) Then                                    MatResult = "设置材质失败!"                                Else                                    MatResult = "设置材质;"                                End If                                Set PartModel = Nothing                            Else                                OpennedModel.Extension.CustomPropertyManager("").Add3 "材料", swCustomInfoText, .Cells(posn, 11), swCustomPropertyReplaceValue                                MatResult = "设置材质;"                            End If                        End If                        ModelMat = ""                    Case "prop"                        OpennedModel.Extension.CustomPropertyManager("").Get2 "外型尺寸", PropVal, Sizes                        OpennedModel.Extension.CustomPropertyManager("").Get2 "图号", PropVal, ModelCode                        OpennedModel.Extension.CustomPropertyManager("").Get2 "图名", PropVal, ModelName                        If Sizes <> .Cells(posn, 7) Then                            PropResult = "尺寸;"                            OpennedModel.Extension.CustomPropertyManager("").Add3 "外型尺寸", swCustomInfoText, .Cells(posn, 7), swCustomPropertyReplaceValue                        End If                        Sizes = ""                        If ModelCode <> .Cells(posn, 12) Then                            PropResult = PropResult & "图号;"                            OpennedModel.Extension.CustomPropertyManager("").Add3 "图号", swCustomInfoText, .Cells(posn, 12), swCustomPropertyReplaceValue                        End If                        ModelCode = ""                        If ModelName <> .Cells(posn, 13) Then                            PropResult = PropResult & "图名;"                            OpennedModel.Extension.CustomPropertyManager("").Add3 "图名", swCustomInfoText, .Cells(posn, 13), swCustomPropertyReplaceValue                        End If                        ModelName = ""                        '...其余属性依次拓展                        If PropResult = "" Then                            PropResult = "属性未改;"                        Else                            PropResult = "设置属性;"                        End If                        GoTo SetNext                    End Select                    OpennedModel.Save2 True: swApp.QuitDoc FullModelPath: Set OpennedModel = Nothing                    Results = AsmMsg & MatResult & PropResult                    AsmMsg = "": MatResult = "": PropResult = ""                End If                .Cells(posn, 1) = Results: Results = ""            Next        Else            MsgBox "未选择正确行，程序结束!", vbExclamation, "不正经的机械仙人"        End If    End With    Err.Clear    Set swApp = Nothing    Application.StatusBar = FalseEnd SubSub CalSwModelInf() '图号分离，可拓展计算属性Dim k As Integer, posn As Long, CodeName As VariantDim Result As String    With ThisWorkbook.ActiveSheet        If myselcondi Then            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在计算：", "共" & Selnumber & "个，第" & k & "个 ..."                posn = Selarray(k)                CodeName = Split(.Cells(posn, 3), "_")                Select Case UBound(CodeName)                Case -1                    Result = ""                Case 0                    .Cells(posn, 13) = CodeName(0)                    Result = "仅图名;"                Case 1                    .Cells(posn, 12) = CodeName(0)                    .Cells(posn, 13) = CodeName(1)                    Result = "图号分离;"                End Select                .Cells(posn, 1) = Result: Result = ""            Next        Else            MsgBox "未选择正确行，程序结束!", vbExclamation, "不正经的机械仙人"        End If    End With    Application.StatusBar = FalseEnd Sub