Partnumber - automatic change by VBA macro

[ralfmja]

Hello all,

I would like to change partnumber in my project in "automatic mode " like on scheme below: 

I have a simple code, but it works only for parts on one BOM level and does not save the scheme 0.001 ... 1.001 etc. (I do not think that's the way):

Sub Zmiana_partnumber()
Dim asmDoc As AssemblyDocument
Set asmDoc = ThisApplication.ActiveDocument
Dim oBom As BOM
Set oBom = asmDoc.ComponentDefinition.BOM
oBom.StructuredViewEnabled = True
oBom.StructuredViewFirstLevelOnly = False
Dim oBOMView As BOMView
Set oBOMView = oBom.BOMViews(2)
Dim compDef As ComponentDefinition
Dim doc As Document
Dim row As BOMRow
Dim prop As Property
Dim NUMER As String
Dim Licznik As Long
NUMER = InputBox("Wprowadź NUMER", "Okno wprowadzania", xx_xxxx)
For Each row In oBOMView.BOMRows
Set compDef = row.ComponentDefinitions(1)
Set doc = compDef.Document
If compDef.Type = kVirtualComponentDefinitionObject Then
Set prop = compDef.PropertySets("Design Tracking Properties")("Part Number")
Else
Set prop = doc.PropertySets("Design Tracking Properties")("Part Number")
End If
Licznik = Licznik + 1
If doc.IsModifiable Then
If prop.Value <> NUMER Then prop.Value = NUMER & "-" & Licznik
End If
Next
End Sub

The next thing would be copying the entire file structure to a new folder, changing the names of files to part numbers 🙂

Is it possible to do this type of macro in VBA at all?

Thanks in advance,

ralfmj

[MechMachineMan]

Yes, it's definitely possible.

I suggest your read up more on VBA and search the forums a little better as there are many, many examples of the same thing being done.

[ralfmja]

Thank for your reply,
Can you give me similar example of topic which can be useful for me ??

I can't find solution which I can use in my case ...

Many thanks,

ralfmj

[MechMachineMan]

Below is a link to a thread with multiple different approaches encompassed in it.

https://forums.autodesk.com/t5/inventor-forum/renaming-mass-amounts-of-files/td-p/6801209

[ralfmja]

Sorry but it's not for me. I tried to use many tools but it wasn't good for me ....

Best for me is a design assistant but it's very manual tool.

If you use DA in case a 1000part assembly you must click 1000 time change filename etc. If you do 1 mistake you can start again. You loose many time which can be dedicate for design.

For me the best way is dedicated macro in VBA which I can't write alone ... I need help VBA master who has time for me and my problem 🙂

[MechMachineMan]

Well thanks for not even looking at the link then.

There are 2 excel vba tools in there that rename parts without the drawback of the Design Assitant stuff.

There is also a lot of code in there that is very similar and requires subtle tweaks to get it to how you want it.

Sounds like you just want somebody to do all of the work for you, for free. An alternative would be to do some learning on VBA/vb.net so you fix it yourself.

[MechMachineMan]

'Code adapted from Owner2229.

Sub Test()
    'ThisApplication.SilentOperation = True
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    oPrefix = InputBox("Enter new prefix", "Helper", "XXX")
    oInt = 1

    oNewName = GetNewName(oDoc.FullFileName)
    Call UpdatePartNumber(oDoc, oNewName)
    Call oDoc.SaveAs(oNewName, False)

    Call RenameChildFiles(oDoc)
    Call oDoc.Save
    'ThisApplication.SilentOperation = False
End Sub

Dim oInt As Integer
Dim oPrefix As String

Public Sub RenameChildFiles(oDoc As Inventor.Document)
    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 RenameChildFiles(aDoc)
        End If

        Dim oNewName As String
        oNewName = GetNewName(oName)
        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) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)

    Dim oPath As String
    oPath = Left(oName, FNP)
    oExt = RIGHT(oName, 4)

    Dim oNumber As String
    oNumber = oInt.ToString("0000")

    Dim oNewName As String
    GetNewName = oPath & oPref & "-" & oNumber & oExt
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

[ralfmja]

Thanks alot for your help

You have right I don't have knowledge about VB so I count for good people on this forum I'm very happy that you want help me.

In this way I "wrote" few very helpfull macro which help me in daily work.

I know itsn't easy but I think it's possible.

Below you can see what kind of problem I have with code above.

I know that should convert number of occurance to string (like on my photos in first post)  but we have error .

[MechMachineMan]

So what that line does is changes the "part id number" into a 4 character digit. Using any available VBA method that turns "1" into "0001" would be fine. Should be able to google it and find an answer quick. I don't have inventor on this computer to test and debug.

[MechMachineMan]

I think this version should function better...

Dim oInt As Integer
Dim oPrefix As String

Sub Test()
    'ThisApplication.SilentOperation = True
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
    oPrefix = InputBox("Enter new prefix", "Helper", "XXX")
    oInt = 1
    
    Dim oNewName As String
    oNewName = GetNewName(oDoc.FullFileName)
    Call UpdatePartNumber(oDoc, oNewName)
    Call oDoc.SaveAs(oNewName, False)

    Call RenameChildFiles(oDoc)
    Call oDoc.Save
    'ThisApplication.SilentOperation = False
End Sub

Public Sub RenameChildFiles(oDoc As Inventor.Document)
    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 RenameChildFiles(aDoc)
        End If

        Dim oNewName As String
        oNewName = GetNewName(oName)
        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) As String
    Dim FNP As Integer
    FNP = InStrRev(oName, "\", -1)

    Dim oPath As String
    oPath = Left(oName, FNP)
    oExt = Right(oName, 4)

    Dim oNumber As String
    oNumber = Format(oInt, "0000")

    Dim oNewName As String
    GetNewName = oPath & oPref & "-" & oNumber & oExt
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

  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}")
    Set iProperty = oPropSet.Item(oProp)
    Exit Function
IPCatch:
    Call oPropSet.Add("", oProp)
    Set iProperty = oPropSet.Item(oProp)
End Function