01-05-2024
10:57 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
01-05-2024
10:57 PM
It's showing another error now: {000208DA-0000-0000-C000-000000000046}
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.