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
