'定义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
本站仅提供存储服务,所有内容均由用户发布,如发现有害或侵权内容,请
点击举报。