''This macro wil export all paramaters to excel. ''Macro created by Fréderic Vandenplas ''Copyright by Inventor Wizard (http://www.inventorwizard.be) ''Use this macro at your own risk. ''You may only copy/modify this or part of the code if you leave this header! Public Sub Exportparameters2excel() 'check of part actief is alvorens macro op te starten Dim oDoc As Document Set oDoc = ThisApplication.ActiveDocument If oDoc.DocumentType <> kPartDocumentObject Then MsgBox "Deze Macro werkt enkel op een part (.ipt)" Exit Sub End If ExportParameters End Sub Sub ExportParameters() Dim oParam As Parameter Dim m_Doc As Document Set m_Doc = ThisApplication.ActiveDocument Dim ParameterArray(0 To 100), ParameterArray1(0 To 100), ParameterArray2(0 To 100) Dim Xitem, Yitem As Integer 'aanmaken van een excelsheet Dim ExcelApp As Excel.Application Dim Workbookobj As Excel.Workbook Dim Sheetobj As Excel.WorkSheet Set ExcelApp = CreateObject("Excel.Application") Set Workbookobj = ExcelApp.Workbooks.Add(1) Set Sheetobj = Workbookobj.ActiveSheet 'itereren door de parameters For Each oParam In m_Doc.ComponentDefinition.Parameters ParameterArray(Xitem) = oParam.Name ParameterArray1(Xitem) = oParam.Expression ParameterArray2(Xitem) = oParam.Units Sheetobj.Cells(Xitem + 1, 1) = ParameterArray(Xitem) Sheetobj.Cells(Xitem + 1, 2) = ParameterArray1(Xitem) Sheetobj.Cells(Xitem + 1, 3) = ParameterArray2(Xitem) Xitem = Xitem + 1 Next 'checken of er parameters zijn en al dan niet excel openen If Xitem = 0 Then ExcelApp.Quit MsgBox "No Parameters in this part.", , "Exporting parameters." Else Sheetobj.Name = "Parameters from inventor" ExcelApp.Visible = True End If 'geheugen vrijmaken Set ExcelApp = Nothing End Sub