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

for everyone interested in my solution i came up with. its part german part english, sry.

Sub ResolveParts()

    Dim oFile As Inventor.file
    Dim oFileDescriptor As FileDescriptor
    Dim oFileDescriptor2 As FileDescriptor
    Dim oFileName As String
    Dim PartNumber As String
    Dim SearchFolder As String
    Dim FileFound As String
    Dim FileFoundTemp As String
    Dim FileType As String
    Dim RefMis As String
    Dim Response As VbMsgBoxResult
    Dim MacroRun As VbMsgBoxResult
    Dim pos As Integer
    Dim MatchingFiles() As String
    Dim FileIndex As Integer
    Dim test As String
    Dim UnresolvedParts() As String ' Array for unresolved parts
    Dim UnresolvedIndex As Integer
    Dim MaxUnresolved As Integer
    Dim UnresolvedIndex2 As Integer
    Dim FoundButUnresolvableParts() As String ' Array for parts that were found but could not be resolved
    Dim FoundButUnresolvableIndex As Integer
    Dim ReferenceCount As Integer
    Dim CurrentPartCounter As Integer
    
    Dim oDoc As Document
    Dim oApp As Application
    
    Set oApp = ThisApplication
    Set oDoc = oApp.ActiveDocument
    
    ' Set the search folder path
    SearchFolder = "C:\BigFolder"

    ' Initialize array for unresolved parts
    ReDim UnresolvedParts(0)
    UnresolvedIndex = 0
    MaxUnresolved = 50 ' Maximum unresolved parts before displaying a message
    ' Initialize array for parts that were found but not resolvable
    ReDim FoundButUnresolvableParts(0)
    FoundButUnresolvableIndex = 0
    CurrentPartCounter = 0
    
    If Not oDoc.DocumentType = kPartDocumentObject Then
    
    
replaceit:
    
        ' Get the active document's file reference
        If oDoc.DocumentType = kDrawingDocumentObject Then
            Set oFile = oDoc.ReferencedDocuments(1).file
        Else
            Set oFile = oDoc.file
        End If
        
        ' Loop through each referenced file descriptor
    
        For Each oFileDescriptor In oFile.ReferencedFileDescriptors
    
            ' Check if the reference is missing
            If oFileDescriptor.ReferenceMissing Then
                
                If Not nrr = 1 Then
                    nrr = 1
                    
                    For Each oFileDescriptor2 In oFile.ReferencedFileDescriptors

                        If oFileDescriptor2.ReferenceMissing Then
                        
                            ReferenceCount = ReferenceCount + 1
                                                        
                        End If
                        
                    Next
                    
                    MacroRun = MsgBox("Would you like to try resolving the " & ReferenceCount & " parts?", vbYesNo + vbQuestion)
                    
                End If
                
                If MacroRun = vbYes Then
                
                    RefMis = oFileDescriptor.FullFileName
                    RefMis = Right(RefMis, Len(RefMis) - InStrRev(RefMis, "\"))
                    
                    ' Extract the part number from the missing reference's filename
                    If InStr(RefMis, " ") > 1 Then
                        PartNumber = Left(RefMis, InStr(RefMis, " ") - 1)
                    ElseIf InStr(RefMis, "_") > 1 Then
                        PartNumber = Left(RefMis, InStr(RefMis, "_") - 1)
                    ElseIf InStr(RefMis, "-") > 1 Then
                        PartNumber = Left(RefMis, InStr(RefMis, "-") - 1)
                    Else
                        ' No delimiter found, skip this iteration
                        GoTo NextFileDescriptor
                    End If
                    
                    ' Initialize the array for storing potential matches
                    FileIndex = 0
                    ReDim MatchingFiles(0)
                    
                    ' Search for a matching file in the specified folder
                    FileType = Right(RefMis, 4)
                    FileFoundTemp = SearchFolder & PartNumber & "*" & FileType
                    FileFound = Dir(FileFoundTemp, vbNormal)
                    
                    ' Collect all matching files in the array
                    Do While FileFound <> ""
                        ReDim Preserve MatchingFiles(FileIndex)
                        MatchingFiles(FileIndex) = FileFound
                        FileIndex = FileIndex + 1
                        FileFound = Dir
                    Loop
                    
                    ' If potential matches were found, prompt the user
                    If FileIndex > 0 Then
                        CurrentPartCounter = CurrentPartCounter + 1
                        For FileIndex = LBound(MatchingFiles) To UBound(MatchingFiles)
                            Response = MsgBox("The missing part was found:" & vbCrLf & vbCrLf & _
                                              RefMis & " (old)" & vbCrLf & MatchingFiles(FileIndex) & " (new)" & vbCrLf & vbCrLf & _
                                              "Would you like to resolve it?", _
                                              vbYesNoCancel + vbExclamation, "Part " & CurrentPartCounter & "/" & ReferenceCount & " Resolve")
                            
                            If Response = vbYes Then
                                ' Resolve the reference using the selected file
                                On Error Resume Next
                                Dim TryCount As Integer
                                TryCount = 0
                                
                                Do
                                    Err.Clear
                                    oFileDescriptor.ReplaceReference SearchFolder & MatchingFiles(FileIndex)
                                    If Err.Number = 5 Then
                                        TryCount = TryCount + 1
                                        If TryCount >= 3 Then
                                            ' If not resolvable, add to array
                                            ReDim Preserve FoundButUnresolvableParts(FoundButUnresolvableIndex)
                                            FoundButUnresolvableParts(FoundButUnresolvableIndex) = RefMis
                                            FoundButUnresolvableIndex = FoundButUnresolvableIndex + 1
                                            MsgBox "Reference could not be replaced for: " & vbCrLf & RefMis, vbCritical
                                            Exit Do
                                        End If
                                    Else
                                        Exit Do ' Successfully replaced, exit loop
                                    End If
                                Loop
                                On Error GoTo 0
                                
                                Exit For
                            ElseIf Response = vbCancel Then
                                ' Cancel the entire operation if the user selects Cancel
                                MsgBox "Procedure cancelled.", vbCritical
                                Exit Sub
                            End If
                        Next FileIndex
                    Else
                        ' If no match was found, add to UnresolvedParts array
                        ReDim Preserve UnresolvedParts(UnresolvedIndex)
                        UnresolvedParts(UnresolvedIndex) = RefMis
                        UnresolvedIndex = UnresolvedIndex + 1
                        UnresolvedIndex2 = UnresolvedIndex2 + 1
                        
                        ' Check if 20 unresolved parts have been found
                        If UnresolvedIndex >= MaxUnresolved Then
                            MsgBox UnresolvedIndex2 & " unresolved parts were found:" & vbCrLf & Join(UnresolvedParts, vbCrLf), vbCritical, "Unresolved Parts"
                            UnresolvedIndex = 0
                        End If
                    End If
                End If
                
                If oDoc.DocumentType = kDrawingDocumentObject Then
                    oDoc.ReferencedDocuments(1).Update
                    oDoc.ReferencedDocuments(1).Update2
                End If
            End If
NextFileDescriptor:
        Next

        ' Ausgabe der verbleibenden nicht auflösbaren Teile
        If UnresolvedIndex > 0 Then
            MsgBox "Die folgenden Teile konnten nicht in" & vbCrLf & vbCrLf & SearchFolder & vbCrLf & vbCrLf & "aufgelöst werden:" & vbCrLf & vbCrLf & Join(UnresolvedParts, vbCrLf), vbInformation, "Nicht auflösbare Teile"
            Erase UnresolvedParts
            UnresolvedIndex = 0
            
        End If
        
        ' Ausgabe der Teile, die gefunden aber nicht auflösbar waren
        
        ' Zweiter Suchdurchgang in anderem Ordner
        If Not nr = 2 Then
            nr = 2
            SearchFolder = Left(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\"))
            GoTo replaceit
        End If
        
        If FoundButUnresolvableIndex > 0 Then
            MsgBox "Die folgenden Teile wurden gefunden, konnten aber nicht aufgelöst werden:" & vbCrLf & vbCrLf & Join(FoundButUnresolvableParts, vbCrLf), vbCritical, "Gefunden aber nicht auflösbar"
        End If
        
        ThisApplication.ActiveDocument.Update
        ThisApplication.ActiveDocument.Update2
        
    Else
    
        MsgBox "Bitte nur aus einer Baugruppe oder aus einer Zeichnung starten. Abgeleitete Baugruppen können nicht mit diesem Makro aufgelöst werden.", vbExclamation
        
    End If
        

End Sub