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