Rule ilogic o VBA in Inventor 2015 to subtitute and rename a mass of assembly in

[Anonymous]

Hi, I have a problem:I have an assembly containing a mass of assembleys.
Often I have to update all those assembley changing the last part of their names, the better thing would be substitute each assembly and rename the new one substituing the last part of name with an other. The important thing is that all the assembleys have the same last part of name and I have to substitute this part with the same text for each assembleys.
Just this, not copy the parts and subassembly contained in those assembly,just riutilize them . This assembleys are normal (not ilogic, no iassembly)
Could you write to me a rule (better would be VBA but ok also ilogic if you are able to do by it) to do this automatically for whole assembleys contained in my assembly? I don't need form or similar, it could be sufficiently to write the text to substitute and the newone at code level
Actually I make it by design assistance but I lose a lot of time each time.
Thank you for you help

[Anonymous]

Ah ok, no problem, my drawings and assembly will always have the same names.
E.g.:

Xxxed0.iam
Xxxed0.idw

Wwwed0.iam
Wwwedo.idw
...

[Owner2229]

Alright, here below is your updated code. You should test it first.

There might be a problem with the document replacing. This code will replace all referenced documents with the one of the same name, so If you have another (different) document placed in the drawing, than it will be replaced as well. The solution for this would require a little bit more coding, so let me know if it is or isn't a problem.

Basicaly it shouldn't be a problem if you're ussing only one assembly document per drawing.

Sub Test()
    Dim TextToFind As String
    TextToFind = "ed0"
    Dim TextToReplace As String
    TextToReplace = "_logo_ed1"
    Dim NewFolder As String
    ' Leave this string empty to copy to current folder
    NewFolder = "C:\MyFiles\"
    Dim UpdateDrawings As Boolean
    ' "True" to update and move drawings, "False" to just update them
    CopyDrawings = True

    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oDoc.ComponentDefinition.Occurrences
        Dim aDoc As Document
        Set aDoc = oOcc.Definition.Document
        If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Dim oName As String
            oName = aDoc.FullFileName
            Dim xDoc As Document
            Set xDoc = ThisApplication.Documents.Open(oName, False)
            Dim FNP As Integer
            FNP = InStrRev(oName, "\", -1)
            Dim oPath As String
            If NewFolder = "" Then
                oPath = Left(oName, FNP)
            Else
                oPath = NewFolder
            End If
            Dim oNewName As String
            oNewName = Mid(oName, FNP + 1)
            Dim FRP As Integer
            FRP = oNewName.LastIndexOf(TextToFind)
            If Not FRP = -1 Then
                oNewName = oNewName.Remove(FRP, Len(TextToFind)).Insert(FRP, TextToReplace)
            End If
            xDoc.SaveAs (oPath & oNewName), False
            xDoc.Close (True)
            ThisApplication.SilentOperation = True
            Dim yDoc As Document
            Set yDoc = ThisApplication.Documents.Open(Left(oName, Len(oName) - 3) & "idw"), False)
            Dim oRefFile As FileDescriptor
            For Each oRefFile In yDoc.File.ReferencedFileDescriptors
                oRefFile.ReplaceReference(oPath & oNewName)
            Next
            If CopyDrawings Then
                yDoc.SaveAs (oPath & Left(oNewName, Len(oNewName) - 3) & "idw"), False
            Else
                yDoc.Save
            End If
            yDoc.Close(True)
            ThisApplication.SilentOperation = False
        End If
    Next
End Sub

[Anonymous]

Hi,

after a massive use of this rule (with a lot of satisfaction) I see a problem: this rule doesn't make the same operation of "save and replace" button there is in Inventor ,that is replace all the iam files at first level in an assembly  with others with new name and also its part number in iproprietis with the same name of the file name, but new file have the old part numbers! 

Is there a method to make the same operation that makes the button "save and replace" ?

And for all the files I have already generated with the rule (hundreds)  is there a method or a new rule to update the old part number with the same name of the file name?

Thank you for your time, I hope you could help me.

I semplified a little your rule , it is sufficiently it salve and rename in the same folder, I attach it below,i use it as a external rule in ilogic:

Dim TextToFind As String = "CFB"
Dim TextToReplace As String = "AAACFB"
Dim oDoc As Document = ThisApplication.ActiveDocument
Dim oOcc As ComponentOccurrence
For Each oOcc In oDoc.ComponentDefinition.Occurrences
    Dim aDoc As Document = oOcc.Definition.Document
    If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
        Dim oName As String = aDoc.FullFileName
        Dim xDoc As Document = ThisApplication.Documents.Open(oName, True)
        Dim FNP As Integer = InStrRev(oName, "\", -1)
        Dim oPath As String = Left(oName, FNP)
        Dim oNewName As String = Mid(oName, FNP + 1)
        oNewName = oNewName.Replace(TextToFind, TextToReplace)
        xDoc.SaveAs(oPath & oNewName, False)
        xDoc.Close(True)
    End If
Next

[Anonymous]

has somenone some idea about? Thank you

[Owner2229]

Hey there, the function of "Save As" is held by the code you have.

The function of "Replace" is held by the code you have removed (blue in my post above).

As for the Part numbers, include this in the for each loop:

Dim FName As String = aDoc.FullFileName
Dim FNP As Integer = InStrRev(FName, "\", -1)
Dim PN As String = Microsoft.VisualBasic.Mid(FName, FNP + 1)
PN = Microsoft.VisualBasic.Left(PN, Microsoft.VisualBasic.Len(PN) - 4)
iProperty(aDoc, "Part Number").Expression = PN

Here is the function called by the code above, add it somewhere below your code:

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
	Dim oPropsets As PropertySets = oDoc.PropertySets
	Dim oPropSet As PropertySet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
	Try
		iProperty = oPropSet.Item(oProp)
	Catch
		oPropSet.Add("", oProp)
		iProperty = oPropSet.Item(oProp)
	End Try
	oPropsets = Nothing
	oPropSet = Nothing
End Function

[Anonymous]

THank you for your time.

But I don't know where i have to add the code you post, Because I have some error when I try to run the new macro.

I've tried you "sub Test" but it returns an error and i post a screenshot about.

Could you help me please?

And also I'm not able to make a function that updates the part numbers with the same name of the file name of the files in a assembly,some errors also there

[Owner2229]

Here below is the updated version of the code. It sould now also work for multi level assemblies (you can disable it by commenting out the blue lines).

It no longer goes throught every occurrence, so it sould be a bit fater.

Here's the whole functionality of the code:

1) Set's focus on currently open (active) document

2) Goes throught every refferenced document...

    - If the document is an assembly, it goes throught every of it's refferenced documents

    - Renames it and saves under new name

    - Writes in the new PartNumber

    - Replaces the refference in the assembly

3) Renames, updates PartNumber and saves under new name the top assembly (can be disabled by commenting out the green text)

Let me know if this is what you wanted the code to do and/or if there're any mistakes or errors.

Also this is the VBA version of the code (it took some time to translate), so let me know if you want the VB.Net version instead.

Sub Test()
    ThisApplication.SilentOperation = True
    Dim TextToFind As String
    TextToFind = "CFB"
    Dim TextToReplace As String
    TextToReplace = "AAACFB"
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    Call ReplaceSubs(oDoc, TextToFind, TextToReplace)
    Dim oNewName As String
    oNewName = oDoc.FullFileName
    oNewName = GetNewName(oNewName, TextToFind, TextToReplace)
    oDoc.SaveAs oNewName, False
    UpdatePartNumber(oDoc)
    oDoc.Save
    ThisApplication.SilentOperation = False
End Sub

Public Sub ReplaceSubs(oDoc As Inventor.Document, TextToFind As String, TextToReplace As String)
    Dim oRefFile As FileDescriptor
    For Each oRefFile In oDoc.File.ReferencedFileDescriptors
        Dim oName As String
        oName = oRefFile.FullFileName
        Dim aDoc As Inventor.Document
        Set aDoc = ThisApplication.Documents.Open(oName, False)
        If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Call ReplaceSubs(aDoc, TextToFind, TextToReplace)
        End If
        Dim oNewName As String
        oNewName = GetNewName(oName, TextToFind, TextToReplace)
        aDoc.SaveAs oNewName, False
        UpdatePartNumber(aDoc)
        aDoc.Save
        aDoc.Close (True)
        oRefFile.ReplaceReference (oNewName)
    Next
End Sub

Public Function GetNewName(oName As String, TextToFind As String, TextToReplace As String) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)
    Dim oPath As String
    oPath = Left(oName, FNP)
    Dim oNewName As String
    oNewName = Mid(oName, FNP + 1)
    GetNewName = Replace(oNewName, TextToFind, TextToReplace)
End Function

Public Sub UpdatePartNumber(oDoc As Inventor.Document)
    Dim PN As String
    PN = oDoc.FullFileName
    Dim FNP As Integer
    FNP = InStrRev(PN, "\", -1)
    PN = Mid(PN, FNP + 1)
    PN = Left(PN, Len(PN) - 4)
    iProperty(oDoc, "Part Number").Expression = PN
End Sub

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
    Dim iPro As Inventor.Property
    On Error GoTo IPCatch
    Dim oPropsets As PropertySets
    Set oPropsets = oDoc.PropertySets
    Dim oPropSet As PropertySet
    Set oPropSet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
    iProperty = oPropSet.Item(oProp)
IPCatch:
    Call oPropSet.Add("", oProp)
    iProperty = oPropSet.Item(oProp)
End Function

[Anonymous]

Hi, thank oyu for your solution, but there is some issues.... I add some missing "call" and when I try to execute this macro It return an error: i attach a screenshot. Could you make something about please? If you are more sure writing a rule instead a macro for me no problem. Thank you in advance for your help

[Anonymous]

here is the screenshot

[Owner2229]

Hmm, it looks like it want's the parameters enclosed in brackets (it throwed an error when I tried it on my PC).

Let's try it like this (orange is what I changed).

If it won't work, try to comment out the SilentOperation sets.

Sub Test()
    ThisApplication.SilentOperation = True
    Dim TextToFind As String
    TextToFind = "CFB"
    Dim TextToReplace As String
    TextToReplace = "AAACFB"
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    Call ReplaceSubs(oDoc, TextToFind, TextToReplace)
    Dim oNewName As String
    oNewName = oDoc.FullFileName
    oNewName = GetNewName(oNewName, TextToFind, TextToReplace)
    Call oDoc.SaveAs(oNewName, False)
    Call UpdatePartNumber(oDoc)
    Call oDoc.Save()
    ThisApplication.SilentOperation = False
End Sub

Public Sub ReplaceSubs(oDoc As Inventor.Document, TextToFind As String, TextToReplace As String)
    Dim oRefFile As FileDescriptor
    For Each oRefFile In oDoc.File.ReferencedFileDescriptors
        Dim oName As String
        oName = oRefFile.FullFileName
        Dim aDoc As Inventor.Document
        Set aDoc = ThisApplication.Documents.Open(oName, False)
        If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Call ReplaceSubs(aDoc, TextToFind, TextToReplace)
        End If
        Dim oNewName As String
        oNewName = GetNewName(oName, TextToFind, TextToReplace)
        Call aDoc.SaveAs(oNewName, False)
        Call UpdatePartNumber(aDoc)
        Call aDoc.Save()
        Call aDoc.Close (True)
        Call oRefFile.ReplaceReference (oNewName)
    Next
End Sub

Public Function GetNewName(oName As String, TextToFind As String, TextToReplace As String) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)
    Dim oPath As String
    oPath = Left(oName, FNP)
    Dim oNewName As String
    oNewName = Mid(oName, FNP + 1)
    GetNewName = Replace(oNewName, TextToFind, TextToReplace)
End Function

Public Sub UpdatePartNumber(oDoc As Inventor.Document)
    Dim PN As String
    PN = oDoc.FullFileName
    Dim FNP As Integer
    FNP = InStrRev(PN, "\", -1)
    PN = Mid(PN, FNP + 1)
    PN = Left(PN, Len(PN) - 4)
    iProperty(oDoc, "Part Number").Expression = PN
End Sub

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
    Dim iPro As Inventor.Property
    On Error GoTo IPCatch
    Dim oPropsets As PropertySets
    Set oPropsets = oDoc.PropertySets
    Dim oPropSet As PropertySet
    Set oPropSet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
    iProperty = oPropSet.Item(oProp)
IPCatch:
    Call oPropSet.Add("", oProp)
    iProperty = oPropSet.Item(oProp)
End Function

[Anonymous]

Thank you for your time, but neither this time it goes fine.

There is something wrong about the function "saveas", I attach the screenshot below, when I run the sub it crash there,where  i mark in blue in the screenshot...

[Owner2229]

I've found the issue. I forgot to add the path back to the filename after the replacement.

I'm also not sure (as I didn't work with VBA for some time) if this statement should have brackets or not, so test it out:

Call aDoc.Close (True)

Sub Test()
    ThisApplication.SilentOperation = True
    Dim TextToFind As String
    TextToFind = "CFB"
    Dim TextToReplace As String
    TextToReplace = "AAACFB"
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    Call ReplaceSubs(oDoc, TextToFind, TextToReplace)
    Dim oNewName As String
    oNewName = oDoc.FullFileName
    oNewName = GetNewName(oNewName, TextToFind, TextToReplace)
    Call oDoc.SaveAs(oNewName, False)
    Call UpdatePartNumber(oDoc)
    Call oDoc.Save()
    ThisApplication.SilentOperation = False
End Sub

Public Sub ReplaceSubs(oDoc As Inventor.Document, TextToFind As String, TextToReplace As String)
    Dim oRefFile As FileDescriptor
    For Each oRefFile In oDoc.File.ReferencedFileDescriptors
        Dim oName As String
        oName = oRefFile.FullFileName
        Dim aDoc As Inventor.Document
        Set aDoc = ThisApplication.Documents.Open(oName, False)
        If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Call ReplaceSubs(aDoc, TextToFind, TextToReplace)
        End If
        Dim oNewName As String
        oNewName = GetNewName(oName, TextToFind, TextToReplace)
        Call aDoc.SaveAs(oNewName, False)
        Call UpdatePartNumber(aDoc)
        Call aDoc.Save()
        Call aDoc.Close (True)
        Call oRefFile.ReplaceReference (oNewName)
    Next
End Sub

Public Function GetNewName(oName As String, TextToFind As String, TextToReplace As String) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)
    Dim oPath As String
    oPath = Left(oName, FNP)
    Dim oNewName As String
    oNewName = Mid(oName, FNP + 1)
    oNewName = Replace(oNewName, TextToFind, TextToReplace)
    GetNewName = oPath & oNewName
End Function

Public Sub UpdatePartNumber(oDoc As Inventor.Document)
    Dim PN As String
    PN = oDoc.FullFileName
    Dim FNP As Integer
    FNP = InStrRev(PN, "\", -1)
    PN = Mid(PN, FNP + 1)
    PN = Left(PN, Len(PN) - 4)
    iProperty(oDoc, "Part Number").Expression = PN
End Sub

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
    Dim iPro As Inventor.Property
    On Error GoTo IPCatch
    Dim oPropsets As PropertySets
    Set oPropsets = oDoc.PropertySets
    Dim oPropSet As PropertySet
    Set oPropSet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
    iProperty = oPropSet.Item(oProp)
IPCatch:
    Call oPropSet.Add("", oProp)
    iProperty = oPropSet.Item(oProp)
End Function

[MechMachineMan]

Quick question Mike:

Won't this current set-up ruin the references in all of the current assembly docs that aren't getting renamed?

As I understand, it will open up an assembly, go through, save new versions of the referenced files, and replace the references, but doesn't actually change the assembly document first?

So shouldn't this actually look more like this to actually replace the assembly file first?

Sub Test()
    ThisApplication.SilentOperation = True
    Dim TextToFind As String
    TextToFind = "CFB"
    Dim TextToReplace As String
    TextToReplace = "AAACFB"
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    
    Dim oNewName As String
    oNewName = GetNewName(oDoc.FullFileName, TextToFind, TextToReplace)
    Call oDoc.SaveAs(oNewName, False)
    Dim oNewDoc As Document
    Set oNewDoc = ThisApplication.Documents.Open(oNewName, True)

    Call ReplaceSubs(oNewDoc, TextToFind, TextToReplace)

    Call UpdatePartNumber(oNewDoc)
    Call oNewDoc.Save()
    ThisApplication.SilentOperation = False
    Call oDoc.Close() 'This might cause a "Pure Vital Function call error/Catastrophic failure error" if so, remove it
End Sub

Public Sub ReplaceSubs(oDoc As Inventor.Document, TextToFind As String, TextToReplace As String)
    Dim oRefFile As FileDescriptor
    For Each oRefFile In oDoc.File.ReferencedFileDescriptors
        
        Dim oName As String
        oName = oRefFile.FullFileName

        Dim aDoc As Inventor.Document
        Set aDoc = ThisApplication.Documents.Open(oName, False)

        Dim oNewName As String
        oNewName = GetNewName(oName, TextToFind, TextToReplace)
        Call aDoc.SaveAs(oNewName, False)

        Dim oNewDoc As Inventor.Document
        Set oNewDoc = ThisApplication.Documents.Open(oNewName, False)

        Call aDoc.Close()

        If oNewDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Call ReplaceSubs(oNewDoc, TextToFind, TextToReplace)
        End If

        Call UpdatePartNumber(oNewDoc)
        Call oNewDoc.Save()
        Call oNewDoc.Close (True)
        Call oRefFile.ReplaceReference (oNewName)
    Next
End Sub

Public Function GetNewName(oName As String, TextToFind As String, TextToReplace As String) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)
    Dim oPath As String
    oPath = Left(oName, FNP)
    Dim oNewName As String
    oNewName = Mid(oName, FNP + 1)
    oNewName = Replace(oNewName, TextToFind, TextToReplace)
    GetNewName = oPath & oNewName
End Function

Public Sub UpdatePartNumber(oDoc As Inventor.Document)
    Dim PN As String
    PN = oDoc.FullFileName
    Dim FNP As Integer
    FNP = InStrRev(PN, "\", -1)
    PN = Mid(PN, FNP + 1)
    PN = Left(PN, Len(PN) - 4)
    iProperty(oDoc, "Part Number").Expression = PN
End Sub

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
    Dim iPro As Inventor.Property
    On Error GoTo IPCatch
    Dim oPropsets As PropertySets
    Set oPropsets = oDoc.PropertySets
    Dim oPropSet As PropertySet
    Set oPropSet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
    iProperty = oPropSet.Item(oProp)
IPCatch:
    Call oPropSet.Add("", oProp)
    iProperty = oPropSet.Item(oProp)
End Function  

[Owner2229]

Hey, you're kinda right, it will "mess up" the references (kind of), but that's the intention, because when you change a document you're changing a temp copy of the original document, so when you do a "Save As", you're actualy saving the temp document. Basicaly, all the original data are safe as long as you don't mistakenly run "Save" function instead of "Save As".

As you can see in the rule, I'm first calling "Save As", then I'm updating the PartNumber, as it is derived from the new filename and finnaly "Save" to save the part number in the file.

Hmm, you just gave me an idea... As I already know the new name, I don't realy need the second "Save", as I can write in the new PartNumber before the "Save As".

So, here's the little change. It sould run slightly faster this way.

Sub Test()
    ThisApplication.SilentOperation = True
    Dim TextToFind As String
    TextToFind = "CFB"
    Dim TextToReplace As String
    TextToReplace = "AAACFB"
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    Call ReplaceSubs(oDoc, TextToFind, TextToReplace)
    Dim oNewName As String
    oNewName = oDoc.FullFileName
    oNewName = GetNewName(oNewName, TextToFind, TextToReplace)
    Call UpdatePartNumber(oDoc, oNewName)
    Call oDoc.SaveAs(oNewName, False)
    ThisApplication.SilentOperation = False
End Sub

Public Sub ReplaceSubs(oDoc As Inventor.Document, TextToFind As String, TextToReplace As String)
    Dim oRefFile As FileDescriptor
    For Each oRefFile In oDoc.File.ReferencedFileDescriptors
        Dim oName As String
        oName = oRefFile.FullFileName
        Dim aDoc As Inventor.Document
        Set aDoc = ThisApplication.Documents.Open(oName, False)
        If aDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject Then
            Call ReplaceSubs(aDoc, TextToFind, TextToReplace)
        End If
        Dim oNewName As String
        oNewName = GetNewName(oName, TextToFind, TextToReplace)
        Call UpdatePartNumber(aDoc, oNewName)
        Call aDoc.SaveAs(oNewName, False)
        Call aDoc.Close (True)
        Call oRefFile.ReplaceReference (oNewName)
    Next
End Sub

Public Function GetNewName(oName As String, TextToFind As String, TextToReplace As String) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)
    Dim oPath As String
    oPath = Left(oName, FNP)
    Dim oNewName As String
    oNewName = Mid(oName, FNP + 1)
    oNewName = Replace(oNewName, TextToFind, TextToReplace)
    GetNewName = oPath & oNewName
End Function

Public Sub UpdatePartNumber(oDoc As Inventor.Document, PN As String)
    Dim FNP As Integer
    FNP = InStrRev(PN, "\", -1)
    PN = Mid(PN, FNP + 1)
    PN = Left(PN, Len(PN) - 4)
    iProperty(oDoc, "Part Number").Expression = PN
End Sub

Public Function iProperty(oDoc As Inventor.Document, oProp As String) As Inventor.Property
    Dim iPro As Inventor.Property
    On Error GoTo IPCatch
    Dim oPropsets As PropertySets
    Set oPropsets = oDoc.PropertySets
    Dim oPropSet As PropertySet
    Set oPropSet = oPropsets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
    iProperty = oPropSet.Item(oProp)
IPCatch:
    Call oPropSet.Add("", oProp)
    iProperty = oPropSet.Item(oProp)
End Function