Sub GetMats() '提取材质Dim swApp As SldWorks.SldWorks, FullModelPath As StringDim OpennedModel As PartDoc, k As Integer, posn As Long, SwErr As LongOn Error Resume Next Set swApp = GetObject(, "SldWorks.Application") If swApp Is Nothing Then MsgBox "请先打开SolidWorks！", vbExclamation, "不正经的机械仙人" Exit Sub End If With ThisWorkbook.ActiveSheet If myselcondi Then 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 .Cells(posn, 11) = OpennedModel.GetMaterialPropertyName2("", "") Set OpennedModel = Nothing swApp.QuitDoc FullModelPath If .Cells(posn, 11) = "" Then .Cells(posn, 1) = "无材质！" Else .Cells(posn, 1) = "材质√" End If End If Else .Cells(posn, 1) = "装配，按设计" .Cells(posn, 11) = "BYDESIGN" End If Next Else MsgBox "未选择正确行，程序结束！", vbExclamation, "不正经的机械仙人" End If End With Err.Clear Application.StatusBar = FalseEnd Sub
Sub SetMats() '设置材质Dim swApp As SldWorks.SldWorks, FullModelPath As StringDim OpennedModel As ModelDoc2, PartModel As PartDoc, k As Integer, posn As Long, SwErr As LongDim MatsDb As String'On Error Resume Next Set swApp = GetObject(, "SldWorks.Application") If swApp Is Nothing Then MsgBox "请先打开SolidWorks！", vbExclamation, "不正经的机械仙人" Exit Sub End If MatsDb = ThisWorkbook.Sheets("SW0 参数设置").Range("C2").Value With ThisWorkbook.ActiveSheet If myselcondi Then swApp.CloseAllDocuments (True) For k = 1 To Selnumber ProcessBarUpdater k, Selnumber, "正在设置材质：", "共" & Selnumber & "个，第" & k & "个 ..." posn = Selarray(k) FullModelPath = .Cells(posn, 2) & "\" & .Cells(posn, 3) & .Cells(posn, 4) If UCase(.Cells(posn, 4)) = ".SLDPRT" Then Set OpennedModel = swApp.OpenDoc2(FullModelPath, swDocPART, False, False, True, SwErr) If OpennedModel Is Nothing Then .Cells(posn, 1) = "设置失败！" Else Set PartModel = OpennedModel PartModel.SetMaterialPropertyName2 "", MatsDb, .Cells(posn, 11) If PartModel.GetMaterialPropertyName2("", "") <> .Cells(posn, 11) Then .Cells(posn, 1) = "设置失败！" Else PartModel.GraphicsRedraw2 .Cells(posn, 1) = "已设置材质" End If Set PartModel = Nothing End If Else Set OpennedModel = swApp.OpenDoc2(FullModelPath, swDocASSEMBLY, False, False, True, SwErr) If OpennedModel Is Nothing Then .Cells(posn, 1) = "设置失败！" Else OpennedModel.Extension.CustomPropertyManager("").Add3 "材料", swCustomInfoText, .Cells(posn, 11), swCustomPropertyReplaceValue .Cells(posn, 1) = "装配，定制属性" End If End If If Not OpennedModel Is Nothing Then OpennedModel.Save2 True: swApp.QuitDoc FullModelPath Set OpennedModel = Nothing End If Next Else MsgBox "未选择正确行，程序结束！", vbExclamation, "不正经的机械仙人" End If End With Err.Clear Application.StatusBar = FalseEnd Sub
