|
'定義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 '設(shè)定零件地址
f = "D:\" 'link excel Set oExcel = Excel.Application oExcel.Visible = False Set oWB = oExcel.Workbooks.Open("f:\***.xls") 'excel表格位置 Set oWS = oWB.Worksheets(1) '設(shè)置在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) '經(jīng)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) '關(guān)閉編輯完的零件 Set Part = swApp.ActivateDoc2(g, False, longstatus) Part.Save2 True Part.ClearSelection2 True Set Part = Nothing swApp.CloseDoc g '顯示當(dāng)前文件
Set Part = swApp.ActivateDoc2("****.SLDPRT", False, longstatus) aa: j = j + 1 Loop
'關(guān)閉excel oExcel.DisplayAlerts = False oWB.Close oExcel.Quit Set oWS = Nothing Set oWB = Nothing Set oExcel = Nothing strErrMsg = "SetCustomProps Sub Routine" & strErrMsg End Sub |
|
|
