11-26-2024
11:49 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
11-26-2024
11:49 PM
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