Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.
aurel_e
in reply to: WCrihfield

It's showing another error now: {000208DA-0000-0000-C000-000000000046}

aurel_e_0-1704524116324.png

 

This is the code:

AddReference "Microsoft.Office.Interop.Excel.dll"
Imports Microsoft.Office.Interop
Imports Microsoft.Office.Interop.Excel
Sub Main
	If ThisDoc.Document.DocumentType <> DocumentTypeEnum.kAssemblyDocumentObject Then Return
	Dim oADoc As AssemblyDocument = ThisDoc.Document
	Dim oRefDocs As DocumentsEnumerator = oADoc.AllReferencedDocuments
	Dim oList As New List(Of String)
	Dim iCount As Integer = 0
	For Each oRefDoc As Inventor.Document In oRefDocs
		If oRefDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
			If oList.Contains(oRefDoc.FullFileName) = False Then
				oList.Add(oRefDoc.FullFileName)
				iCount = iCount + 1
			End If
		End If
	Next
	MsgBox("There are " & iCount & " unique sub assemblies in this assembly.", vbInformation, "iLogic")
	'same path and file name as this assembly, but with ".xlsx" file extension
	Dim sExcelFile As String = System.IO.Path.ChangeExtension(oADoc.FullFileName, ".xlsx")
	WriteListToExcel(oList, sExcelFile)
End Sub

Sub WriteListToExcel(oList As List(Of String), Optional sExcelFileName As String = vbNullString, Optional sExcelSheetName As String = vbNullString)
	If oList Is Nothing OrElse oList.Count = 0 Then Return
	Dim oExcel As Object = GetExcel
	If oExcel Is Nothing Then Return
	oExcel.Visible = True
	oExcel.DisplayAlerts = True
	Dim oWB As Workbook = oExcel.Workbooks.Add()
	If oWB Is Nothing Then Return
	Dim oWS As Worksheet
	If oWB.Worksheets.Count = 0 Then
		oWS = oWB.Worksheets.Add()
	Else
		oWS = oWB.Worksheets.Item(1)
	End If
	If oWS Is Nothing Then Return
	'add column headers
	oWS.Range("A1").Value = "Part Number"
	oWS.Range("B1").Value = "File Name"
	oWS.Range("C1").Value = "Qty"
	Dim oRow As Integer = 1 'row just above first data row, because loop increments before writing
	For Each oEntry In oList
		oRow = oRow + 1
		'oEntry contains FullFileName (path, file name, and file extension), so we must isolate just file name
		oWS.Cells(oRow, 2) = System.IO.Path.GetFileNameWithoutExtension(oEntry)
	Next
	oWS.Columns.AutoFit
	Try
		oWB.SaveAs(sExcelFileName)
	Catch
		MsgBox("Error trying to save this Excel file as the following:" & vbCrLf & sExcelFileName, vbCritical, "iLogic")
	End Try
	oWS = Nothing
	oWB.Close(False)
	oWB = Nothing
	'oExcel.Quit 'should only quit, if a new instance of Excel was started, but we do not know that
	oExcel = Nothing
End Sub

Function GetExcel(Optional bVisible As Boolean = False) As Object
	Dim oXL As Object
	Try 'try to find an already running instance of the Excel Application
		oXL = GetObject("Excel.Application")
	Catch 'it wasn't found open, so create an instance of it (start the application)
		Try : oXL = CreateObject("Excel.Application") : Catch : End Try
	End Try
	If oXL IsNot Nothing Then oXL.Visible = bVisible
	Return oXL
End Function

 

It looks is the Office 365, that causes the problem.

 

If it is too hard to fix, a txt file will do.

Thanks.