外国创意家具设计:API 批量修改solidwork属性

'定义solidwork
Dim swApp As Object
Dim Part As Object
Dim SelMgr As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long 
Dim Feature As Object
'定义excel
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet Dim a As String
Dim b As String
Dim m As String
Dim e As String
Dim c As String
Dim j As Integer
Dim t As Integer
Dim f As String
Dim g As String
Dim h As String
Dim i As Integer
Dim k As Integer
Dim p As Integer   Sub main() On Error GoTo aa 
'link solidworks
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1 '设定零件地址
f = "D:\" 
'link excel
Set oExcel = Excel.Application
oExcel.Visible = False
Set oWB = oExcel.Workbooks.Open("f:\***.xls")   'excel表格位置
Set oWS = oWB.Worksheets(1) 
'设置在excel中的查找代码,查找各个属性
j = 2 Do Until Sheets(1).Cells(j, 2) = "" h = Sheets(1).Cells(j, 2) i = 1
Do Until Mid(h, i, 1) = "."
i = i + 1
Loop
i = i + 1 b = Mid(h, i, 6) Select Case b
Case Is = "SLDPRT"
k = 1
Case Is = "SLDASM"
k = 2
End Select 
'生成零件具体位置
g = f & h ' & ".SLDPRT" 
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1
'打开零件
'Part.OpenCompFile
Set Part = swApp.OpenDoc6(g, k, 0, "", longstatus, longwarnings) '记录零件名称
h = Sheets(1).Cells(j, 2) 
'经excel赋值
a = Sheets(1).Cells(j, 3) 'Description
'm = Sheets(1).Cells(j, 4)
'e = Sheets(1).Cells(j, 3) '编辑零件 '清空solidwork旧的属性 blnretval = Part.DeleteCustomInfo2("", "物料编码")
'blnretval = Part.DeleteCustomInfo2("", "坯料尺寸") 
'加入新的solidwork属性 blnretval = Part.AddCustomInfo3("", "Material", swCustomInfoText, a)
'blnretval = Part.AddCustomInfo3("", "坯料尺寸", swCustomInfoText, m) 
'关闭编辑完的零件
Set Part = swApp.ActivateDoc2(g, False, longstatus)
Part.Save2 True
Part.ClearSelection2 True
Set Part = Nothing
swApp.CloseDoc g '显示当前文件
Set Part = swApp.ActivateDoc2("****.SLDPRT", False, longstatus) 
aa:
j = j + 1 Loop 
'关闭excel
oExcel.DisplayAlerts = False
oWB.Close
oExcel.Quit
Set oWS = Nothing
Set oWB = Nothing
Set oExcel = Nothing 
strErrMsg = "SetCustomProps Sub Routine" & strErrMsg
End Sub