Excel VBA to import iProperties in a celll?

[fabianrebora]

I need to make a list in excel of all files that I have Inventor.

List several of its iProperties (Part Number, stock number, Description, materials, ......)

I could only make a macro to access the properties that handles Windows (Name, Date Created, Folder, ……)

No programming in Visual Basic, only what you can find on the internet.

If someone could help me, I'll be very grateful

 ‘Force the explicit delcaration of variables
Option Explicit

Sub ListFiles()

‘Set a reference to Microsoft Scripting Runtime by using
‘Tools > References in the Visual Basic Editor (Alt+F11)

‘Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String

‘Insert the headers for Columns A through F
Range(“A1”).Value = “Name”
Range(“B1”).Value = “Size”
Range(“C1”).Value = “Type”
Range(“D1”).Value = “Date Created”
Range(“E1”).Value = “Date Last Accessed”
Range(“F1”).Value = “Date Last Modified”

‘Assign the top folder to a variable
strTopFolderName = “Q:\ArchivosCAD\Planera\ACUMULADOR (AC)”

‘Create an instance of the FileSystemObject
Set objFSO = CreateObject(“Scripting.FileSystemObject”)

‘Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)

‘Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)

‘Change the width of the columns to achieve the best fit
Columns.AutoFit

End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)

‘Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long

‘Find the next available row
NextRow = Cells(Rows.Count, “A”).End(xlUp).Row + 1

‘Loop through each file in the folder
For Each objFile In objFolder.Files
Cells(NextRow, “A”).Value = objFile.Name
Cells(NextRow, “B”).Value = objFile.Size
Cells(NextRow, “C”).Value = objFile.Type
Cells(NextRow, “D”).Value = objFile.DateCreated
Cells(NextRow, “E”).Value = objFile.DateLastAccessed
Cells(NextRow, “F”).Value = objFile.DateLastModified
Cells(NextRow, “G”).Value = objFile.ParentFolder
NextRow = NextRow + 1
Next objFile

‘Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If

End Sub

[MechMachineMan · Accepted solution]

'Requires Apprentice Server Availability
'Add reference to Inventor Object Library Interop

Option Compare Text

Public oList As Collection

Sub UpdateFittingList()

    Dim FSO As New FileSystemObject
    
    ActiveWorkbook.ActiveSheet.Rows("3:" & Rows.Count).Clear

    Dim apprentice As Inventor.ApprenticeServerComponent
    Set apprentice = New Inventor.ApprenticeServerComponent
    
    Dim apprenticeDoc As Inventor.ApprenticeServerDocument

    Dim oFolderPath As String
    oFolderPath = "X:\CAD Files\"
    
    Dim oFolder As Folder
    Set oFolder = FSO.GetFolder(oFolderPath)
    
    Set oList = Nothing
    
    If oList Is Nothing Then
        Set oList = New Collection
    End If
        
    Call FolderList(oFolder)
    
    Dim i As Integer
    i = 2
    
    Dim vFolder
    Dim aFolder As Folder
    
    For Each vFolder In oList
    
    Set aFolder = FSO.GetFolder(vFolder)
    
    If aFolder.Files.Count = 0 Then
    Else
            
        
    For Each oFile In aFolder.Files

        If oFile Like "*.ipt" Or oFile Like "*.iam" And Not oFile Like "*Old*" Then
            Set apprenticeDoc = apprentice.Open(oFile)
    
            Dim InvDocDTP As Inventor.PropertySet
            Set InvDocDTP = apprenticeDoc.PropertySets.Item("Design Tracking Properties")
            
            Dim InvDocISI As Inventor.PropertySet
            Set InvDocISI = apprenticeDoc.PropertySets.Item("Inventor Summary Information")
            
            Dim InvDocIDSI As Inventor.PropertySet
            Set InvDocIDSI = apprenticeDoc.PropertySets.Item("Inventor Document Summary Information")
            
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 1) = FSO.GetFileName(oFile)
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 2) = InvDocDTP.Item("Stock Number").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 3) = InvDocIDSI.Item("Category").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 4) = InvDocISI.Item("Keywords").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 5) = InvDocDTP.Item("Description").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 6) = oFile
            
            Call apprenticeDoc.PropertySets.FlushToFile
            
            Set apprenticeDoc = Nothing
            i = i + 1
        End If
    Next
    End If
    Next
 

    Call apprentice.Close
    Set apprentice = Nothing
End Sub
   
Public Sub FolderList(oFolder As Folder)

oList.Add (oFolder)

If oFolder.SubFolders.Count = 0 Then
    Exit Sub
End If

Dim xFolder As Folder

For Each xFolder In oFolder.SubFolders
    If xFolder.Path Like "*Old*" Or xFolder.Path Like "*Legacy*" Then
        'MsgBox (xFolder.Path)
    Else
            Call FolderList(xFolder)
    End If
Next

End Sub

[fabianrebora]

Thank you very much for your answer

Enter the FolderPath = "Q: \ ArchivosCAD \ Planera \ accumulator (AC)"
And a compilation error occurs (is not defined type user-defined) in this line
Public Sub FolderList (oFolder As Folder)

It has also given me in this line herror

Sub UpdateFittingList ()

     Dim FSO As New FileSystemObject
    
     ActiveWorkbook.ActiveSheet.Rows ( "3" & Rows.Count) .Clear

     Dim As apprentice Inventor.ApprenticeServerComponent

I have to enable some Excel add-in to run this macro?

I'm trying to achieve something like a progam called UnReserveAndExport, that works for Inventor 2016.

Sorry for my English, it is enough to read and use a translator to write

[MechMachineMan · Accepted solution]

I think you also need to add a reference to Microsoft Scripting Runtime to
be able to use FileSystemObjects

[fabianrebora · Accepted solution]

I found the problem.

Open the Microsoft Visual Basic (for Application) window through clicking the Developer ribbon tab -> Visual Basic button in the Code ribbon panel.

Open the References dialog by clicking the Tools menu -> References item. Find the Autodesk Inventor Object Library from the checkable list box and tick it

[fabianrebora]

Justin, thank you very much for your previous help.

It has been very useful to me.

But, I have to ask again.

Is it possible to place a miniature view in a cell?

As in the new 2018 version.

Thank you very much for your help.

 Sorry for my english, I used google translator to correct my grammatical errors.

'Requires Apprentice Server Availability
'Add reference to Inventor Object Library Interop

Option Compare Text

Public oList As Collection


Sub Listarplanosinventor()

'Declare the variables  AGREGADO POR MI
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
    
'Insert the headers for Columns A through F AGREGADO POR MI
    Range("A1").Value = "PLANO"
    Range("B1").Value = "REVISION"
    Range("C1").Value = "CODIGO BAS"
    Range("D1").Value = "TIPO"
    Range("E1").Value = "LINEA"
    Range("F1").Value = "EQUIPO"
    Range("G1").Value = "SUBCONJUNTO"
    Range("H1").Value = "DESCRIPCION"
    Range("I1").Value = "MATERIAL"
    Range("J1").Value = "PDF"
    Range("K1").Value = "CARPETA"
    Range("L1").Value = "3D"
    Range("M1").Value = "2D"
    Range("N1").Value = "UBICACION"
    Range("O1").Value = "ARCHIVO"
    Dim FSO As New FileSystemObject
    
    
    
'PROGRAMACION ORIGINAL
    'ActiveWorkbook.ActiveSheet.Rows("3:" & Rows.Count).Clear

    Dim apprentice As Inventor.ApprenticeServerComponent
    Set apprentice = New Inventor.ApprenticeServerComponent
    
    Dim apprenticeDoc As Inventor.ApprenticeServerDocument

    Dim oFolderPath As String
    oFolderPath = "Q:\ArchivosCAD\Planera"
    
    Dim oFolder As Folder
    Set oFolder = FSO.GetFolder(oFolderPath)
    
    Set oList = Nothing
    
    If oList Is Nothing Then
        Set oList = New Collection
    End If
        
    Call FolderList(oFolder)
    
    Dim i As Integer
    i = 1
    
    Dim vFolder
    Dim aFolder As Folder
    
    For Each vFolder In oList
    
    Set aFolder = FSO.GetFolder(vFolder)
    
    If aFolder.Files.Count = 0 Then
    Else
            
        
    For Each oFile In aFolder.Files

        If oFile Like "*.ipt" Or oFile Like "*.iam" And Not oFile Like "*Old*" Then
            Set apprenticeDoc = apprentice.Open(oFile)
    
            Dim InvDocDTP As Inventor.PropertySet
            Set InvDocDTP = apprenticeDoc.PropertySets.Item("Design Tracking Properties")
            
            Dim InvDocISI As Inventor.PropertySet
            Set InvDocISI = apprenticeDoc.PropertySets.Item("Inventor Summary Information")
            
            Dim InvDocIDSI As Inventor.PropertySet
            Set InvDocIDSI = apprenticeDoc.PropertySets.Item("Inventor Document Summary Information")
            
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 1) = InvDocDTP.Item("Part Number").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 2) = InvDocISI.Item("Revision Number").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 3) = InvDocDTP.Item("Stock Number").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 4) = InvDocISI.Item("Subject").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 5) = InvDocISI.Item("Title").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 6) = InvDocIDSI.Item("Category").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 7) = InvDocISI.Item("Keywords").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 8) = InvDocISI.Item("Comments").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 9) = InvDocDTP.Item("material").Value
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 14) = oFile
            ActiveWorkbook.ActiveSheet.Cells(i + 1, 15) = FSO.GetFileName(oFile)
         
                        
            Call apprenticeDoc.PropertySets.FlushToFile
            
            Set apprenticeDoc = Nothing
            i = i + 1
        End If
    Next
    End If
    Next
 

    Call apprentice.Close
    Set apprentice = Nothing
End Sub
   
Public Sub FolderList(oFolder As Folder)

oList.Add (oFolder)

If oFolder.SubFolders.Count = 0 Then
    Exit Sub
End If

Dim xFolder As Folder

For Each xFolder In oFolder.SubFolders
    If xFolder.Path Like "*Old*" Or xFolder.Path Like "*Legacy*" Then
        'MsgBox (xFolder.Path)
    Else
            Call FolderList(xFolder)
    End If
Next

End Sub

[MechMachineMan]

If you really need pictures, yes there is ways to do it. There should be sources on the forums here you can find.

Or, you can export BOM with thumbnails exposed and sort that data into whatever way you like.

[fabianrebora]

Is it possible to add a VBA code to generate it and add it to the excel list I already have?
To be generated in the same way as when exporting to excel with inventor?

thanks for your help

[MechMachineMan · Accepted solution]

Sure.

Something like this should get you on the right path.

Private Sub MakeThumbnailColumn(oStartRow As Integer, oTColumn As Integer, oFileNameColumn As Integer)
    Dim apprentice As Inventor.ApprenticeServerComponent
    Set apprentice = New Inventor.ApprenticeServerComponent
    Dim apprenticeDoc As Inventor.ApprenticeServerDocument
    
    
    oLastRow = ws.Cells(ws.Rows.Count, oFileNameColumn).End(XlDirection.xlUp).Row
    
    For j = oStartRow To oLastRow
        oFName = ws.Cells(j, oFileNameColumn).Value
        If Dir(oFName, vbDirectory) = vbNullString Then GoTo SkipRow
        
        On Error GoTo SkipRow
            Set apprenticeDoc = apprentice.Open(oFName)
        Dim Thumbnail As IPictureDisp
        Set Thumbnail = apprenticeDoc.PropertySets.Item("Inventor Summary Information").Item("Thumbnail").Value
        Call CreateThumbnail(Thumbnail, oTColumn, j)
    
        Call apprenticeDoc.Close
SkipRow:
    Next
    
    apprentice.Close
    Set apprentice = Nothing
End Sub

Private Sub CreateThumbnail(Thumbnail As IPictureDisp, oColumn As Integer, ByVal CellRowNum As Integer)
    'Changed to put N/A in same column as comments. if there is an error, check this first.
    On Error GoTo Handler
    Call stdole.SavePicture(Thumbnail, "C:\Temp\Thumb.jpg")
Handler:
    If Err.Number = 380 Then
        ws.Cells(CellRowNum, oColumn).Value = "N/A"
        Exit Sub
    End If
    
    With ws.Cells(CellRowNum, oColumn)
            .AddComment
            .Comment.Visible = False
            .Comment.Shape.Fill.UserPicture ("C:\Temp\Thumb.jpg")
            .Comment.Shape.Height = 75
            .Comment.Shape.Width = 75
    End With
End Sub

[fabianrebora]

Sorry for my ignorance on the subject, but in which part of the old code do I have to insert this new code?

[MechMachineMan · Accepted solution]

Above is written as a VBA function that uses 'ws' as a global variable.

To implement, you need to call the function. (Make a module in excel (Alt + F11) and drop all of that code in)

Then above that, type this in as a calling sub.

Save the module, go back to excel and run the macro. Or in the Alt-F11 Window, with your mouse in the name SomeStringNameThatWillExecuteThisCode() Press F5.

Private ws As Worksheet

Public Sub SomeStringNameThatWillExecuteThisCode()
     Set ws = Application.ActiveSheet
    
     'Sub MakeThumbnailColumn(oStartRow As Integer, oTColumn As Integer, oFileNameColumn As Integer)
     Call MakeThumbnailColumn(2, 3, 4)

End Sub

This assumes your spreadsheet looks this:

row1:    Column A | Coumn B   | Thumnail Column | FileName Column

row2:    something| something | *thumbnail*          | "C:\File.ipt"

ie; a header row, and then column 4 containing the file name of the file you want a thumnail for.

[fabianrebora]

thanks for your help

I will try to see how to join those two codes.
I have not at the moment

[fabianrebora]

Unfortunately I can not figure out how to generate the code.
I dare to attach the form that I use to generate the master list.
With the code that you gave me before.
If you can help me to modify the code I will be very grateful.

Sorry to bother you,

If you can not, thank you very much too.
The code above was of great help to me

[MechMachineMan · Accepted solution]

Well, I told you exactly how to get the thumbnails, yet I see no effort of even attempting it in your code.

Again, simply copy both of the chunks of code I pasted and put them in 1 module. Tweak the integers used in the calling function "MakeThumbnails..." to match where you want your data read/exported to.

Also, you need to modify your spreadsheet format to include a column that has the FILE NAME of the model for this solution to work.

[fabianrebora]

Okay, thanks for your help

[fabianrebora]

Thanks, I finally made it work

Change in the schedule where WS says by Application.ActiveSheet.
Change also that it is always visible.
I only need to see to make it move and resize with the cell.
And if I run it again without deleting the comments, it does not work.
I guess I have to add before I delete the entire column.

But, you are inserting as a comment.
Not as embedded image

Change part of the programming, but only that it generates the images but one above the other
And without defining properties. Width and height.

At the moment this is the result, inserting comment