Dim swApp As SldWorks.SldWorks Dim swPart As SldWorks.ModelDoc2 Dim xlApp As Excel.Application '需要引用Exelc相关函数,设置引用Microsoft Excel Dim xlWb As Excel.Workbook Dim xlWbs As Excel.Workbooks Dim xlWs As Excel.Worksheet Dim xlPath As String Dim xlFN As String Dim CurRow As Integer Dim myModelDoc() As SldWorks.ModelDoc2 Sub main() On Error Resume Next Set swApp = Application.SldWorks Set swPart = swApp.ActiveDoc xlPath = Environ("USERPROFILE") & "\Desktop\" '获取桌面路径 xlFN = "生产喷涂清单" & ".xlsx" '要保存的Excel文件名称 If Dir(xlPath & xlFN) <> "" Then '如果桌面上有该文件,则删除它 Kill xlPath & xlFN End If Set xlApp = Excel.Application xlApp.Visible = True '新建excel Set xlWbs = Excel.Workbooks Set xlWb = xlWbs.Add() '新建工作表 Set xlWs = xlWb.Worksheets("Sheet1") SetTableHead '设置Excel的表头的函数 xlWb.SaveAs xlPath & xlFN '自动保存文件 ReDim myCommonet(0) CurRow = 2 '在excle填写内容的行数,初始从第二行开始,第一行为表头 '下面9行是往excel输入当前打开的装配体的属性栏的数据,由于遍历装配体不会遍历自身... xlWs.Range("B" & CurRow).Value = swPart.GetCustomInfoValue("", "图号") '输入属性栏中图号的数据到B2区域,下面类似 xlWs.Range("C" & CurRow).Value = swPart.GetCustomInfoValue("", "文件名称") xlWs.Range("D" & CurRow).Value = swPart.GetCustomInfoValue("", "数量") xlWs.Range("E" & CurRow).Value = swPart.GetCustomInfoValue("", "材料") xlWs.Range("F" & CurRow).Value = swPart.GetCustomInfoValue("", "厚度") xlWs.Range("G" & CurRow).Value = swPart.GetCustomInfoValue("", "边界框长度") xlWs.Range("H" & CurRow).Value = swPart.GetCustomInfoValue("", "边界框宽度") xlWs.Range("I" & CurRow).Value = swPart.GetCustomInfoValue("", "表面处理") xlWs.Range("J" & CurRow).Value = swPart.GetCustomInfoValue("", "外形尺寸") CurRow = CurRow + 1 '行数加一 If Not swPart Is Nothing Then '按照设计树遍历当前装配体的全部子装配体和子零件 Dim myFeature As Feature Set myFeature = swPart.FirstFeature ReDim myModelDoc(0) Do While Not myFeature Is Nothing If (myFeature.GetTypeName2 = "Reference" Or myFeature.GetTypeName2 = "ReferencePattern") And swPart.GetType = 2 Then TraFeature swPart, myFeature.Name '调用遍历子装配体函数 End If Set myFeature = myFeature.GetNextFeature Loop End If xlWb.Save End Sub Private Sub TraFeature(ByVal ParModeldoc As SldWorks.ModelDoc2, ByVal ParName As String) '按照设计树顺序遍历装配体 函数 Dim curcomponent As Component2 Set curcomponent = ParModeldoc.GetComponentByName(ParName) If curcomponent Is Nothing Then Exit Sub End If If curcomponent.IsSuppressed = False Then Dim curmodeldoc As SldWorks.ModelDoc2 Set curmodeldoc = curcomponent.GetModelDoc2 ReDim Preserve myModelDoc(UBound(myModelDoc) + 1) Set myModelDoc(UBound(myModelDoc)) = curmodeldoc '下面9行是往excel输入当前装配体内全部子装配体和子零件的的属性栏的数据 xlWs.Range("B" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "图号") xlWs.Range("C" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "文件名称") xlWs.Range("D" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "数量") xlWs.Range("E" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "材料") xlWs.Range("F" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "厚度") xlWs.Range("G" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "边界框长度") xlWs.Range("H" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "边界框宽度") xlWs.Range("I" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "表面处理") xlWs.Range("J" & CurRow).Value = curmodeldoc.GetCustomInfoValue("", "外形尺寸") CurRow = CurRow + 1 If curmodeldoc.GetType = 2 Then Dim myFeatureT As Feature Set myFeatureT = curmodeldoc.FirstFeature Do While Not myFeatureT Is Nothing If (myFeatureT.GetTypeName2 = "Reference" Or myFeatureT.GetTypeName2 = "ReferencePattern") And curmodeldoc.GetType = 2 Then TraFeature curmodeldoc, myFeatureT.Name End If Set myFeatureT = myFeatureT.GetNextFeature Loop End If End If End Sub '设置表头,用户可根据自己的实际要求进行增删,或修改每列的宽度 Public Function SetTableHead() With xlWs.Range("A1:Q1") .Font.Name = "宋体" '字体样式 .Font.Size = 12 '字体大小 .Font.Bold = True '粗体字 .HorizontalAlignment = xlCenter '中心对齐 End With With xlWs.Range("A1") .Value = "序号" .ColumnWidth = 3 '该列宽度 End With With xlWs.Range("B1") .Value = "图号" .ColumnWidth = 20 '该列宽度 End With With xlWs.Range("C1") .Value = "名称" .ColumnWidth = 20 '该列宽度 End With With xlWs.Range("D1") .Value = "数量" .ColumnWidth = 4 '该列宽度 End With With xlWs.Range("E1") .Value = "材料" .ColumnWidth = 10 '该列宽度 End With With xlWs.Range("F1") .Value = "厚度" .ColumnWidth = 5 '该列宽度 End With With xlWs.Range("G1") .Value = "长mm" .ColumnWidth = 8 '该列宽度 End With With xlWs.Range("H1") .Value = "宽mm" .ColumnWidth = 8 '该列宽度 End With With xlWs.Range("I1") .Value = "颜色" .ColumnWidth = 11 '该列宽度 End With With xlWs.Range("J1") .Value = "成型尺寸" .ColumnWidth = 20 End With End Function