Restoration of broken links using iLogic
After your code copies and renames all the files, it will have to continue further. You will have to 'Replace' each ComonentOccurrence within the oAsemDef.Occurrences with the new ones using oOcc.Replace() or oOcc.Replace2() Sub. They both have the option to use ReplaceAll, which would be the better choice in this situation. This should fix your issues.
Wesley Crihfield
(Not an Autodesk Employee)
This isn't fully customized to your file names and paths, but in a hurry (because I'm leaving my office) I threw this code together to show one way to do the whole process.
'Specify path for new files
Dim oNewPath As String = "C:\Temp\"
'Get current Assembly (should be open & active)
Dim oCAsm As AssemblyDocument = ThisApplication.ActiveDocument 'Current Assembly
oCAsm.SaveAs(oNewPath & IO.Path.GetFileNameWithoutExtension(oCoCAsm.FullFileName) & "_Copy.iam",False)
''The active assembly should now be the New Assembly (because we said False to SaveCopyAs option)
Dim oNAsm As AssemblyDocument = ThisApplication.ActiveDocument
Dim oNDef As AssemblyComponentDefinition = oNAsm.ComponentDefinition
For Each oOcc As ComponentOccurrence In oNDef.Occurrences
Dim oOccDoc As Document = oOcc.Definition.Document
Dim oCPath As String = IO.Path.GetDirectoryName(oOccDoc.FullFileName) & "\" 'Current Path
Dim oCFName As String = IO.Path.GetFileName(oOccDoc.FullFileName) 'Current File Name (with extension)
oOccDoc.SaveAs(oNewPath & oCFName)
oOcc.Replace(oNewPath & oCFName, True)
NextWesley Crihfield
(Not an Autodesk Employee)
Since I don't have your files I haven't been able to test this code, but I think something like this should work... Try it and let me know 🙂
Sub Main Dim oDoc As Document oDoc = ThisApplication.ActiveDocument If Not ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then MessageBox.Show("No assembly open..", "KrA") Exit Sub End If Dim origin_path As String, new_path As String, user_input As String, tmp_str As String Dim sFilesToCopy(10) As String user_input = InputBox("What is the new numebr", "YYYY-XXX", "") If Len(user_input) <> 8 Then MessageBox.Show("Invalid input..", "KrA") Exit Sub End If origin_path = Left$(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\")) Dim folderBrowserDialog1 = New System.Windows.Forms.FolderBrowserDialog() Dim path As String = "" If (folderBrowserDialog1.ShowDialog() = System.Windows.Forms.DialogResult.OK) Then new_path = folderBrowserDialog1.SelectedPath Else Return End If If new_path = "" Then MessageBox.Show("User cancelled out of dialog", "KrA") Exit Sub End If sFilesToCopy(0) = "DEPT-YYYY-XXX-05-01 SUPPORT.ipt" sFilesToCopy(1) = "DEPT-YYYY-XXX-05-01 SUPPORT.dwg" sFilesToCopy(2) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.ipt" sFilesToCopy(3) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.dwg" sFilesToCopy(4) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.ipt" sFilesToCopy(5) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.dwg" sFilesToCopy(6) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.ipt" sFilesToCopy(7) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.dwg" sFilesToCopy(8) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.ipt" sFilesToCopy(9) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.dwg" sFilesToCopy(10) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.iam" Dim prevIpt As String Dim copiedParts As New List(Of KeyValuePair(Of String, String)) For i = 0 To 10 Try Dim oProceed As Boolean = True tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13) If System.IO.File.Exists(new_path & "\" & tmp_str) Then Dim oResult As DialogResult = MessageBox.Show("The file: " & new_path & "\" & tmp_str & " already exists" & vbCrLf _ & "Replace?", "File already exists", MessageBoxButtons.YesNo, MessageBoxIcon.Question) If oResult = DialogResult.Yes Try ThisApplication.Documents.ItemByName(new_path & "\" & tmp_str).Close 'Cant delete if open Catch End Try System.IO.File.Delete(new_path & "\" & tmp_str) Else oProceed = False End If End If If oProceed = True 'ThisApplication.SilentOperation = True 'use this if still getting an error Call FileSystem.FileCopy(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) If tmp_str.EndsWith(".ipt") Then prevIpt = new_path & "\" & tmp_str copiedParts.Add(New KeyValuePair(Of String, String)(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str)) End If If tmp_str.EndsWith(".dwg") Dim oDWG As DrawingDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceFileRef(oDWG, origin_path & sFilesToCopy(i - 1), prevIpt) oDWG.Save oDWG.Close End If If tmp_str.EndsWith(".iam") Dim oIAM As AssemblyDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) For Each oPair As KeyValuePair(Of String, String) In copiedParts ReplaceFileRef(oIAM, oPair.Key, oPair.Value) Next oIAM.Save oIAM.Close End If 'Call ThisApplication.FileManager.CopyFile(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) ThisApplication.SilentOperation = False End If Catch MessageBox.Show("Please make sure the file: " & origin_path & sFilesToCopy(i) & " exists!", "Couldn't copy file") End Try Next MessageBox.Show("I hope you like it", "KrA") End Sub Sub ReplaceFileRef(oDoc As Document, FileToReplace As String, NewFile As String) Try oDoc.File.ReferencedFileDescriptors.Item(FileToReplace).ReplaceReference(NewFile) Catch 'Couldn't replace reference End Try End Sub
Jhoel Forshav
Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website
I cant replicate the error of getting the assembly to prompt for file references. I think we can get around the problem by using silent operation though. Try this code. I also added your additional files to copy.
Try this:
Sub Main Dim oDoc As Document oDoc = ThisApplication.ActiveDocument If Not ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then MessageBox.Show("No assembly open..", "KrA") Exit Sub End If Dim origin_path As String, new_path As String, user_input As String, tmp_str As String Dim sFilesToCopy(12) As String user_input = InputBox("What is the new numebr", "YYYY-XXX", "") If Len(user_input) <> 8 Then MessageBox.Show("Invalid input..", "KrA") Exit Sub End If origin_path = Left$(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\")) Dim folderBrowserDialog1 = New System.Windows.Forms.FolderBrowserDialog() Dim path As String = "" If (folderBrowserDialog1.ShowDialog() = System.Windows.Forms.DialogResult.OK) Then new_path = folderBrowserDialog1.SelectedPath Else Return End If If new_path = "" Then MessageBox.Show("User cancelled out of dialog", "KrA") Exit Sub End If sFilesToCopy(0) = "DEPT-YYYY-XXX-05-01 SUPPORT.ipt" sFilesToCopy(1) = "DEPT-YYYY-XXX-05-01 SUPPORT.dwg" sFilesToCopy(2) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.ipt" sFilesToCopy(3) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.dwg" sFilesToCopy(4) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.ipt" sFilesToCopy(5) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.dwg" sFilesToCopy(6) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.ipt" sFilesToCopy(7) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.dwg" sFilesToCopy(8) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.ipt" sFilesToCopy(9) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.dwg" sFilesToCopy(10) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.iam" sFilesToCopy(11) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.dwg" sFilesToCopy(12) ="DEPT-YYYY-XXX-00-01 INI ASS PARAMETER INFO.xlsx" Dim prevIpt As String Dim copiedParts As New List(Of KeyValuePair(Of String, String)) For i = 0 To 12 Try Dim oProceed As Boolean = True tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13) If System.IO.File.Exists(new_path & "\" & tmp_str) Then Dim oResult As DialogResult = MessageBox.Show("The file: " & new_path & "\" & tmp_str & " already exists" & vbCrLf _ & "Replace?", "File already exists", MessageBoxButtons.YesNo, MessageBoxIcon.Question) If oResult = DialogResult.Yes Try ThisApplication.Documents.ItemByName(new_path & "\" & tmp_str).Close 'Cant delete if open Catch End Try System.IO.File.Delete(new_path & "\" & tmp_str) Else oProceed = False End If End If If oProceed = True ThisApplication.SilentOperation = True 'use this if still getting an error Call FileSystem.FileCopy(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) If tmp_str.EndsWith(".ipt") Then prevIpt = new_path & "\" & tmp_str copiedParts.Add(New KeyValuePair(Of String, String)(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str)) End If If tmp_str.EndsWith(".dwg") Dim oDWG As DrawingDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceFileRef(oDWG, origin_path & sFilesToCopy(i - 1), prevIpt) oDWG.Save oDWG.Close End If If tmp_str.EndsWith(".iam") prevIpt = new_path & "\" & tmp_str Dim oIAM As AssemblyDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) For Each oPair As KeyValuePair(Of String, String) In copiedParts ReplaceFileRef(oIAM, oPair.Key, oPair.Value) Next oIAM.Save oIAM.Close End If 'Call ThisApplication.FileManager.CopyFile(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) ThisApplication.SilentOperation = False End If Catch ThisApplication.SilentOperation = False MessageBox.Show("Please make sure the file: " & origin_path & sFilesToCopy(i) & " exists!", "Couldn't copy file") End Try Next MessageBox.Show("I hope you like it", "KrA") End Sub Sub ReplaceFileRef(oDoc As Document, FileToReplace As String, NewFile As String) Try oDoc.File.ReferencedFileDescriptors.Item(FileToReplace).ReplaceReference(NewFile) Catch End Try End Sub
Jhoel Forshav Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website
This should replace the excel-link in the part files and assembly:
Sub Main Dim oDoc As Document oDoc = ThisApplication.ActiveDocument If Not ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then MessageBox.Show("No assembly open..", "KrA") Exit Sub End If Dim origin_path As String, new_path As String, user_input As String, tmp_str As String Dim sFilesToCopy(12) As String user_input = InputBox("What is the new numebr", "YYYY-XXX", "") If Len(user_input) <> 8 Then MessageBox.Show("Invalid input..", "KrA") Exit Sub End If origin_path = Left$(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\")) Dim folderBrowserDialog1 = New System.Windows.Forms.FolderBrowserDialog() Dim path As String = "" If (folderBrowserDialog1.ShowDialog() = System.Windows.Forms.DialogResult.OK) Then new_path = folderBrowserDialog1.SelectedPath Else Return End If If new_path = "" Then MessageBox.Show("User cancelled out of dialog", "KrA") Exit Sub End If sFilesToCopy(0) = "DEPT-YYYY-XXX-00-01 INI ASS PARAMETER INFO.xlsx" sFilesToCopy(1) = "DEPT-YYYY-XXX-05-01 SUPPORT.ipt" sFilesToCopy(2) = "DEPT-YYYY-XXX-05-01 SUPPORT.dwg" sFilesToCopy(3) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.ipt" sFilesToCopy(4) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.dwg" sFilesToCopy(5) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.ipt" sFilesToCopy(6) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.dwg" sFilesToCopy(7) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.ipt" sFilesToCopy(8) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.dwg" sFilesToCopy(9) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.ipt" sFilesToCopy(10) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.dwg" sFilesToCopy(11) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.iam" sFilesToCopy(12) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.dwg" Dim prevIpt As String Dim newExcel As String = new_path & "\" & "DEPT-" & user_input & Right$(sFilesToCopy(0), Len(sFilesToCopy(0)) -13) Dim copiedParts As New List(Of KeyValuePair(Of String, String)) For i = 0 To 12 Try Dim oProceed As Boolean = True tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13) If System.IO.File.Exists(new_path & "\" & tmp_str) Then Dim oResult As DialogResult = MessageBox.Show("The file: " & new_path & "\" & tmp_str & " already exists" & vbCrLf _ & "Replace?", "File already exists", MessageBoxButtons.YesNo, MessageBoxIcon.Question) If oResult = DialogResult.Yes Try ThisApplication.Documents.ItemByName(new_path & "\" & tmp_str).Close 'Cant delete if open Catch End Try System.IO.File.Delete(new_path & "\" & tmp_str) Else oProceed = False End If End If If oProceed = True ThisApplication.SilentOperation = True 'use this if still getting an error Call FileSystem.FileCopy(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) If tmp_str.EndsWith(".ipt") Then prevIpt = new_path & "\" & tmp_str copiedParts.Add(New KeyValuePair(Of String, String)(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str)) Dim oIPT As PartDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceOLERef(oIPT, sFilesToCopy(0), newExcel) oIPT.Save oIPT.Close End If If tmp_str.EndsWith(".dwg") Dim oDWG As DrawingDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceFileRef(oDWG, origin_path & sFilesToCopy(i - 1), prevIpt) oDWG.Save oDWG.Close End If If tmp_str.EndsWith(".iam") prevIpt = new_path & "\" & tmp_str Dim oIAM As AssemblyDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) For Each oPair As KeyValuePair(Of String, String) In copiedParts ReplaceFileRef(oIAM, oPair.Key, oPair.Value) Next ReplaceOLERef(oIAM, sFilesToCopy(0), newExcel) oIAM.Save oIAM.Close End If 'Call ThisApplication.FileManager.CopyFile(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) ThisApplication.SilentOperation = False End If Catch ThisApplication.SilentOperation = False MessageBox.Show("Please make sure the file: " & origin_path & sFilesToCopy(i) & " exists!", "Couldn't copy file") End Try Next MessageBox.Show("I hope you like it", "KrA") End Sub Sub ReplaceFileRef(oDoc As Document, FileToReplace As String, NewFile As String) Try oDoc.File.ReferencedFileDescriptors.Item(FileToReplace).ReplaceReference(NewFile) Catch End Try End Sub Sub ReplaceOLERef(oDoc As Document, oldPath As String, newPath As String) For Each oTable As ParameterTable In oDoc.ComponentDefinition.Parameters.ParameterTables If oTable.FileName = oldPath oTable.FileName = newPath End If Next oDoc.Update2(True) End Sub
Jhoel Forshav Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website
Nice code.
I think it may be simpler and more stable to replace the value of "tmp_str" with:
tmp_str = sFilesToCopy(i).Replace("YYYY-XXX",user_input)instead of
tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13)Just a suggestion.
Wesley Crihfield
(Not an Autodesk Employee)
Now I have created my own file structure with assembly, parts, drawings and excel document. All with the same names as yours so I could test this properly. There was an error with the sub to replace the excel reference. I fixed it now and for me everything works 100%. I don't know what made the error message appear for you. That I couldn't reproduce.
This code works for me though. Give it a try 🙂
Sub Main Dim oDoc As Document oDoc = ThisApplication.ActiveDocument If Not ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then MessageBox.Show("No assembly open..", "KrA") Exit Sub End If Dim origin_path As String, new_path As String, user_input As String, tmp_str As String Dim sFilesToCopy(12) As String user_input = InputBox("What is the new numebr", "YYYY-XXX", "") If Len(user_input) <> 8 Then MessageBox.Show("Invalid input..", "KrA") Exit Sub End If origin_path = Left$(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\")) Dim folderBrowserDialog1 = New System.Windows.Forms.FolderBrowserDialog() Dim path As String = "" If (folderBrowserDialog1.ShowDialog() = System.Windows.Forms.DialogResult.OK) Then new_path = folderBrowserDialog1.SelectedPath Else Return End If If new_path = "" Then MessageBox.Show("User cancelled out of dialog", "KrA") Exit Sub End If sFilesToCopy(0) = "DEPT-YYYY-XXX-00-01 INI ASS PARAMETER INFO.xlsx" sFilesToCopy(1) = "DEPT-YYYY-XXX-05-01 SUPPORT.ipt" sFilesToCopy(2) = "DEPT-YYYY-XXX-05-01 SUPPORT.dwg" sFilesToCopy(3) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.ipt" sFilesToCopy(4) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.dwg" sFilesToCopy(5) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.ipt" sFilesToCopy(6) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.dwg" sFilesToCopy(7) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.ipt" sFilesToCopy(8) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.dwg" sFilesToCopy(9) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.ipt" sFilesToCopy(10) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.dwg" sFilesToCopy(11) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.iam" sFilesToCopy(12) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.dwg" Dim prevIpt As String Dim newExcel As String = new_path & "\" & "DEPT-" & user_input & Right$(sFilesToCopy(0), Len(sFilesToCopy(0)) -13) Dim copiedParts As New List(Of KeyValuePair(Of String, String)) For i = 0 To 12 Try Dim oProceed As Boolean = True tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13) If System.IO.File.Exists(new_path & "\" & tmp_str) Then Dim oResult As DialogResult = MessageBox.Show("The file: " & new_path & "\" & tmp_str & " already exists" & vbCrLf _ & "Replace?", "File already exists", MessageBoxButtons.YesNo, MessageBoxIcon.Question) If oResult = DialogResult.Yes Try ThisApplication.Documents.ItemByName(new_path & "\" & tmp_str).Close 'Cant delete if open Catch End Try System.IO.File.Delete(new_path & "\" & tmp_str) Else oProceed = False End If End If If oProceed = True ThisApplication.SilentOperation = True 'use this if still getting an error Call FileSystem.FileCopy(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) If tmp_str.EndsWith(".ipt") Then prevIpt = new_path & "\" & tmp_str copiedParts.Add(New KeyValuePair(Of String, String)(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str)) Dim oIPT As PartDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceOLERef(oIPT, sFilesToCopy(0), newExcel) oIPT.Save oIPT.Close End If If tmp_str.EndsWith(".dwg") Dim oDWG As DrawingDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceFileRef(oDWG, origin_path & sFilesToCopy(i - 1), prevIpt) oDWG.Save oDWG.Close End If If tmp_str.EndsWith(".iam") prevIpt = new_path & "\" & tmp_str Dim oIAM As AssemblyDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) For Each oPair As KeyValuePair(Of String, String) In copiedParts ReplaceFileRef(oIAM, oPair.Key, oPair.Value) Next ReplaceOLERef(oIAM, sFilesToCopy(0), newExcel) oIAM.Save oIAM.Close End If ThisApplication.SilentOperation = False End If Catch MessageBox.Show("Please make sure the file: " & origin_path & sFilesToCopy(i) & " exists!", "Couldn't copy file") End Try Next ThisApplication.SilentOperation = False MessageBox.Show("I hope you like it", "KrA") End Sub Sub ReplaceFileRef(oDoc As Document, FileToReplace As String, NewFile As String) Try oDoc.File.ReferencedFileDescriptors.Item(FileToReplace).ReplaceReference(NewFile) Catch End Try End Sub Sub ReplaceOLERef(oDoc As Document, oldName As String, newPath As String) For Each oTable As ParameterTable In oDoc.ComponentDefinition.Parameters.ParameterTables If oTable.FileName.Contains(oldName) oTable.FileName = newPath End If Next oDoc.Update2(True) End Sub
Jhoel Forshav Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website
@moraesorlando wrote:"About the error messages, is not possible to use those silent operation again?
The process of copying is OK, It is just necessary eliminate these messages."
We are using silent operation still. I don't know what the problem is now. It's difficult for me to debug this when it works as expected when I try it...
Jhoel Forshav Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website
Accepted solution
I'm using Inventor 2020 at the moment.
In order to run the rule automatically when the file is opened we'll have to add an Event Trigger for that event.
I guess you don't want the rule to be triggered for the copied file when that is openes aswell, so I added a line to remove all event triggers from the copy.
In order to be able to close the document after the rule has finished, the best thing would be to run the rule as an external rule. It's difficult to have the rule close the document in which it's running. You'd have to create a new thread to do that.
I have modified a code with regards to these last two requests and also created a screencast to show you how to add the event trigger and external rule. The screencast will also show you that everything is working. My computer could really use a reboot, so code runs a bit slow in the screencast. It was a lot faster when I ran it at home earlier.
The rule:
Sub Main Dim oDoc As Document oDoc = ThisApplication.ActiveDocument If Not ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then MessageBox.Show("No assembly open..", "KrA") Exit Sub End If Dim origin_path As String, new_path As String, user_input As String, tmp_str As String Dim sFilesToCopy(12) As String user_input = InputBox("What is the new numebr", "YYYY-XXX", "") If Len(user_input) <> 8 Then MessageBox.Show("Invalid input..", "KrA") Exit Sub End If origin_path = Left$(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "\")) Dim folderBrowserDialog1 = New System.Windows.Forms.FolderBrowserDialog() Dim path As String = "" If (folderBrowserDialog1.ShowDialog() = System.Windows.Forms.DialogResult.OK) Then new_path = folderBrowserDialog1.SelectedPath Else Return End If If new_path = "" Then MessageBox.Show("User cancelled out of dialog", "KrA") Exit Sub End If sFilesToCopy(0) = "DEPT-YYYY-XXX-00-01 INI ASS PARAMETER INFO.xlsx" sFilesToCopy(1) = "DEPT-YYYY-XXX-05-01 SUPPORT.ipt" sFilesToCopy(2) = "DEPT-YYYY-XXX-05-01 SUPPORT.dwg" sFilesToCopy(3) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.ipt" sFilesToCopy(4) = "DEPT-YYYY-XXX-04-01 EXTERNAL PLATE.dwg" sFilesToCopy(5) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.ipt" sFilesToCopy(6) = "DEPT-YYYY-XXX-03-01 INTERNAL PLATE.dwg" sFilesToCopy(7) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.ipt" sFilesToCopy(8) = "DEPT-YYYY-XXX-02-01 SIDE LEFT PLATE.dwg" sFilesToCopy(9) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.ipt" sFilesToCopy(10) = "DEPT-YYYY-XXX-01-01 SIDE RIGHT PLATE.dwg" sFilesToCopy(11) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.iam" sFilesToCopy(12) = "DEPT-YYYY-XXX-00-01 MACH ASSEMBLY.dwg" Dim prevIpt As String Dim newExcel As String = new_path & "\" & "DEPT-" & user_input & Right$(sFilesToCopy(0), Len(sFilesToCopy(0)) -13) Dim copiedParts As New List(Of KeyValuePair(Of String, String)) For i = 0 To 12 Try Dim oProceed As Boolean = True tmp_str = "DEPT-" & user_input & Right$(sFilesToCopy(i), Len(sFilesToCopy(i)) -13) If System.IO.File.Exists(new_path & "\" & tmp_str) Then Dim oResult As DialogResult = MessageBox.Show("The file: " & new_path & "\" & tmp_str & " already exists" & vbCrLf _ & "Replace?", "File already exists", MessageBoxButtons.YesNo, MessageBoxIcon.Question) If oResult = DialogResult.Yes Try ThisApplication.Documents.ItemByName(new_path & "\" & tmp_str).Close 'Cant delete if open Catch End Try System.IO.File.Delete(new_path & "\" & tmp_str) Else oProceed = False End If End If If oProceed = True ThisApplication.SilentOperation = True Call FileSystem.FileCopy(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str) If tmp_str.EndsWith(".ipt") Then prevIpt = new_path & "\" & tmp_str copiedParts.Add(New KeyValuePair(Of String, String)(origin_path & sFilesToCopy(i), new_path & "\" & tmp_str)) Dim oIPT As PartDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceOLERef(oIPT, sFilesToCopy(0), newExcel) oIPT.Save oIPT.Close End If If tmp_str.EndsWith(".dwg") Dim oDWG As DrawingDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) ReplaceFileRef(oDWG, origin_path & sFilesToCopy(i - 1), prevIpt) oDWG.Save oDWG.Close End If If tmp_str.EndsWith(".iam") prevIpt = new_path & "\" & tmp_str Dim oIAM As AssemblyDocument = ThisApplication.Documents.Open(new_path & "\" & tmp_str, False) For Each oPair As KeyValuePair(Of String, String) In copiedParts ReplaceFileRef(oIAM, oPair.Key, oPair.Value) Next ReplaceOLERef(oIAM, sFilesToCopy(0), newExcel) oIAM.PropertySets.Item("{2C540830-0723-455E-A8E2-891722EB4C3E}").Delete() 'Delete trigger oIAM.Save oIAM.Close End If ThisApplication.SilentOperation = False End If Catch MessageBox.Show("Please make sure the file: " & origin_path & sFilesToCopy(i) & " exists!", "Couldn't copy file") End Try Next ThisApplication.SilentOperation = False MessageBox.Show("I hope you like it", "KrA") oDoc.Close() End Sub Sub ReplaceFileRef(oDoc As Document, FileToReplace As String, NewFile As String) Try oDoc.File.ReferencedFileDescriptors.Item(FileToReplace).ReplaceReference(NewFile) Catch End Try End Sub Sub ReplaceOLERef(oDoc As Document, oldName As String, newPath As String) For Each oTable As ParameterTable In oDoc.ComponentDefinition.Parameters.ParameterTables If oTable.FileName.Contains(oldName) oTable.FileName = newPath End If Next oDoc.Update2(True) End Sub
Screencast:
Jhoel Forshav Download my free Inventor Addin - Hole Projector
LinkedIn | Ideas | Contributions | Blog posts | Website