Hello,
A little while ago I posted a question asking to find out how to do the above. With your help and a few books I have managed to get to that stage where I can get all the dimension, and extrusion data from all parts in an assembly - I have pasted this macro below, for anyone who is interested.
What I would like to get is the Mates data from the main assembly - Could someone suggest how I can pull this out please?
Also, is there anyway of getting the macro to go into sub assemblies to pull data out from them?
Thanks for your help
Guy
Option Explicit
Dim swApp As Object
Dim Part As Object
Dim swModel As ModelDoc2
Dim swConf As Configuration
Dim swRootComponent As Component2
'Counters for arrays
Dim a As Single
Dim b As Single
Dim c As Single
Dim d As Single
Dim e As Single
'Array variables for excel
Dim MydimName(1000) As Variant 'As String
Dim MydimValue(1000) As Variant 'As Single
Dim MydimTolType() As Variant
Dim MydimTolvalue() As Variant
Dim MydimDiametric() As Variant
'Set Excel stuff
Dim xlApp As Excel.Application
Dim xlBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Sub main()
Set swApp = Application.SldWorks
Set swApp = GetObject("", "SldWorks.Application")
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Failed to get active document"
End If
Dim title As String
Dim filetype As Integer
title = swModel.GetTitle()
filetype = swModel.GetType()
Set swConf = swModel.GetActiveConfiguration() 'Get current configuration
Set swRootComponent = swConf.GetRootComponent()
'Reset Counters
a = 0
b = 0
c = 0
d = 0
e = 0
TraverseComponent swRootComponent
End Sub
Sub TraverseComponent(component As Component2)
'Moves through parts
Dim children As Variant
children = component.GetChildren()
If UBound(children) > 0 Then
Dim i As Integer
For i = 1 To UBound(children)
a = a + 1
MsgBox children(i).GetModelDoc().GetTitle()
TraverseFeatures children(i).FirstFeature()
'TraverseComponent children(i)
Next
End If
Call ExportToExcel2
End Sub
Sub TraverseFeatures(feature As feature)
'Moves through features
Dim feat As feature
Set feat = feature
While Not feat Is Nothing
b = b + 1
'MsgBox feat.Name
TraverseSubFeatures feat
Set feat = feat.GetNextFeature
Wend
End Sub
Sub TraverseSubFeatures(feature As feature)
'Moves through SubFeatures
Dim feat As feature
Dim IDimension As Variant
Dim IDisplayDimension As Variant
Dim i As Single
Set feat = feature.GetFirstSubFeature
While Not feat Is Nothing
c = c + 1
'MsgBox feat.Name
'TraversSubfeatures feat
Set IDisplayDimension = feature.GetFirstDisplayDimension
i = 0
While (Not IDisplayDimension Is Nothing)
d = d + 1
i = i + 1
Set IDimension = IDisplayDimension.GetDimension
'swApp.SendMsgToUser ParamName + " = " + Str(Value) 'Swks message box
MydimName(d) = IDimension.FullName
MydimValue(d) = IDimension.Value
Set IDisplayDimension = feature.GetNextDisplayDimension(IDisplayDimension)
Wend
Set feat = feat.GetNextSubFeature
Wend
End Sub
Sub ExportToExcel2()
'Open "C:\PDM_Working_dir\Summary_2011.xls" For Output As #1
Dim xlApp As Excel.Application
Dim xlSht As Excel.Worksheet
Dim xlRng As Excel.Range
Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False
xlApp.Workbooks.Open "C:\PDM_Working_dir\Summary_2011b.xls"
xlApp.Visible = True
xlApp.UserControl = True
'ActiveWorkbook.Worksheets("Summary_2011").Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
Range("A1").Select
'Populate Worksheet
For e = 1 To UBound(MydimValue)
Cells(e, 1) = e
Cells(e, 2) = MydimValue(e)
Cells(e, 3) = MydimName(e)
Next e
'Call Workbook_BeforeClose
'Me.Save
'xlApp.Workbooks.Close
'Release Com Objects
Set xlSht = Nothing
Set xlBk = Nothing
Set xlApp = Nothing
End Sub
SolidworksApi macros