Save and Replace component and subcomponent

mat_hijs · ‎11-20-2020

I have an assembly which consists of a standard part, which is the profile, and a bunch of content center parts that are mounted on the profile. I made a configurable master of this and have to place and configure hundreds of them in multiple top level assemblies.

The name of the subassembly is 140 ST 001, 140 ST 002, 140 ST 003, ... and the name of the profile part is 140 SP 001, 140 SP 002, 140 SP 003, ...

The last 3 digits are always the same in the part as in the subassembly, everything before that is fixed.

Right now, I place the master subassembly in the top level assembly, save and replace the master subassembly, and then save and replace the profile part in the subassembly. This works, but I have to do this hundreds of times and would like to be able to do this in one step.

The subassemblies and profile parts are all saved in the same folder.

I would like to create a macro that lets me save and replace the subassembly just like I do now, but then the profile part should be saved and replaced (with the corresponding name) automatically.

How should I go about this?

yan.gauthier · ‎12-02-2020

What you aim to do is to create a copy of both the assembly and subcomponent ?

Are you familiar with VBA ? I might have some sample code, but you will need to adapt it to your project

mat_hijs · ‎12-02-2020

That woukd depend on the complexity, I have made some macro's to automatically constrain components and stuff like that. If you could send me the sample code I can check it out and see if I can adapt it, but at least I'll have a base to start with.

yan.gauthier · ‎12-03-2020

I went through my code that those this and it. In my case, I create a copy of an assembly with all of its components to a folder.

We use it to import standard components, like a Festo Actuator, and rename all the files so it doesn't cause issues when uploading to the Vault.

Private Sub BrowserNameUpdate(oComponent As ComponentOccurrence, oBrowserPane As BrowserPane)

Dim oNodeDefinition As BrowserNodeDefinition
Dim Occurrence As String
Dim ComponentName As String
Dim oNode As BrowserNode
Dim ComponentFileName As String
Dim NodeName As String
Dim fso As Object
Dim OccurrenceDict As Object
Dim count As Integer: count = 0
Dim oOccurrences As ComponentOccurrences
Dim oSubOccurrence As ComponentOccurrence
Dim oSubOccurrences As ComponentOccurrencesEnumerator
Dim DocName As String
Dim oComponentOccurrenceToRename As ComponentOccurrence
Dim oOccurrenceProxy As ComponentOccurrenceProxy
Dim i As Integer
Dim pos As Integer

Dim randomNumber As Long

On Error GoTo BrowserNameUpdateErr

Set OccurrenceDict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")

 'Loop through each component in the three view
For Each oSubOccurrence In oComponent.SubOccurrences
    'Skip welds if in a weldment
    If Not TypeOf oSubOccurrence.Definition Is WeldsComponentDefinition Then
        Set oNode = oBrowserPane.GetBrowserNodeFromObject(oSubOccurrence)
        Set oNodeDefinition = oNode.BrowserNodeDefinition      
        
        ComponentFileName = fso.getbasename(oSubOccurrence.Definition.Document.Fullfilename)

        'Get node name without occurence
        If InStr(1, oNodeDefinition.Label, ":") > 0 Then
            NodeName = Left(oNodeDefinition.Label, InStrRev(oNodeDefinition.Label, ":") - 1)
        Else
            'Set nodename the same as componentFilename to pass over
            NodeName = oNodeDefinition.Label
        End If
        'Compare browser label with occurrence name
        If NodeName <> ComponentFileName Then
            Set oSubOccurrences = oComponent.Definition.Occurrences.AllReferencedOccurrences(oSubOccurrence.Definition.Document)
            
            'Prepare random number between 100000 and 1000
            randomNumber = Int((100000 - 1000 + 1) * Rnd + 1000)
            
            'Check if occurrences is present more than once
            For i = 1 To oSubOccurrences.count
                'Give a random occurrence value between 100000 and 1000
                pos = 1
                oSubOccurrences(i).name = NodeName & (randomNumber + i)
            Next i
            
            For i = 1 To oSubOccurrences.count
                'Give an ordered value
                pos = 2
                oSubOccurrences(i).name = ComponentFileName & ":" & i
            Next i
            pos = 3

        End If      
 
        'Recursively call this sub for sub assembly
        If TypeOf oComponent.Definition.Document Is AssemblyDocument Then
            BrowserNameUpdate oSubOccurrence, oBrowserPane
        End If
    End If
        
    
Next oSubOccurrence

BrowserNameUpdateErr:

If Err Then
    MsgBox "Unexpected Error: " & Err.Description, vbMsgBoxSetForeground, "BrowserNameUpdate"
    Err.Clear
End If

End Sub

Sub BrowserNodeUpdate()
  
Dim invapp As Inventor.Application
Dim odoc As Document
Dim oAssemblyDoc As AssemblyDocument
Dim oPartDoc As PartDocument
Dim oComponentOccurrence As ComponentOccurrence
Dim oNode As BrowserNode
Dim oNodeDefinition As BrowserNodeDefinition
Dim sOccurrence As String
Dim oOccurrences As ComponentOccurrencesEnumerator
Dim ComponentName As String
Dim oBrowserPane As BrowserPane
Dim DocName As String
Dim fso As Object
Dim ComponentFileName As String
Dim OccurrenceDict As Object
Dim NodeName As String
Dim oComponentOccurrenceToRename As ComponentOccurrence
Dim i As Integer


On Error GoTo BrowserNodeUpdateErr

Set invapp = ThisApplication
Set odoc = invapp.ActiveDocument
Set fso = CreateObject("Scripting.FileSystemObject")
Set OccurrenceDict = CreateObject("Scripting.Dictionary")
'Get to the Model Browser tree view on the active assembly
If TypeOf odoc Is AssemblyDocument Then
    Set oAssemblyDoc = odoc
    Set oBrowserPane = oAssemblyDoc.BrowserPanes.item("Model")
        
    For Each oComponentOccurrence In oAssemblyDoc.ComponentDefinition.Occurrences
        'Skip welds if in a weldment
       If Not TypeOf oComponentOccurrence.Definition Is WeldsComponentDefinition Then
            Set oNode = oBrowserPane.GetBrowserNodeFromObject(oComponentOccurrence)
            Set oNodeDefinition = oNode.BrowserNodeDefinition
      
            ComponentFileName = fso.getbasename(oComponentOccurrence.Definition.Document.Fullfilename)

            
            'Get node name without occurence
            If InStr(1, oNodeDefinition.Label, ":") > 0 Then
                NodeName = Left(oNodeDefinition.Label, InStrRev(oNodeDefinition.Label, ":") - 1)
            Else
                'Set nodename the same as componentFilename to pass over
                NodeName = oNodeDefinition.Label
            End If
            'Compare browser label with occurrence name
            If NodeName <> ComponentFileName Then
            
                'Check if occurrences is present more than once
                Set oOccurrences = oAssemblyDoc.ComponentDefinition.Occurrences.AllReferencedOccurrences(oComponentOccurrence.Definition.Document)
                For i = 1 To oOccurrences.count
                    'Give a random occurrence value between 10000 and 1000
                    oOccurrences(i).name = NodeName & Int((10000 - 1000 + 1) * Rnd + 1000)
                Next i
                
                For i = 1 To oOccurrences.count
                    'Give a random occurrence value between 10000 and 1000
                    oOccurrences(i).name = ComponentFileName & ":" & i
                Next i

            End If        

            'Recursively call this sub for sub assembly
            If TypeOf oComponentOccurrence.Definition.Document Is AssemblyDocument Then
                BrowserNameUpdate oComponentOccurrence, oBrowserPane
            End If
        End If
    Next oComponentOccurrence
    oBrowserPane.Refresh
    oBrowserPane.Update
    'BrowserNameUpdate oAssemblyDoc.BrowserPanes.item("Model").TopNode, False
          
End If

BrowserNodeUpdateErr:
If Err Then
    MsgBox "Unexpected Error: " & Err.Description, vbMsgBoxSetForeground, "BrowserNodeUpdate"
    Err.Clear
End If

End Sub

Sub StandardAssembly()

Dim invapp As Inventor.Application
Dim odoc As Document
Dim refDoc As Document
Dim savePath As String
Dim ComponentName As String
Dim count As Integer
Dim partDoc As PartDocument
Dim progBar As ProgressBar
Dim regex As Object
Dim ComposantesPath As String
Dim myDir As Object
Dim myPath As String
Dim Manufacturer As String
Dim fso As Object
Dim myFilePath As String
Dim myNewFolder As String
Dim matches As Object
Dim potentialManufacturer As String
Dim fileExtension As String
Dim FileDesc As FileDescriptor
Dim newFullFileName As String
Dim DocDescriptor As DocumentDescriptor
Dim FiletoCopyCount As Integer: FiletoCopyCount = 0
Dim IdentifiedManufacturer As String
Dim ProposedName As String

Set regex = CreateObject("vbscript.RegExp")
regex.Pattern = "[^_]*" 'Search groups of digits
'[^     begin exclude group
'_      match this character
']      end of exclude group
'*      match exeption any number of times

regex.Global = False 'end after first match

Set fso = CreateObject("Scripting.FileSystemObject")

Set invapp = ThisApplication
Set odoc = invapp.ActiveEditDocument

' Set up composantes directory
ComposantesPath = invapp.FileLocations.Workspace & "\Composantes\"
myPath = ComposantesPath

'Flatten All
If TypeOf odoc Is AssemblyDocument Then
    'Check Assembly is not saved in project directory
    If InStr(1, odoc.Fullfilename, invapp.FileLocations.Workspace) Then 'first check is to allow assembly from outside project directory e.g.: download folder.
        If Not (InStr(1, odoc.Fullfilename, invapp.FileLocations.Workspace & "\Composantes\", vbTextCompare) > 0 Or _
                InStr(1, odoc.Fullfilename, invapp.FileLocations.Workspace & "\Pièces Client\", vbTextCompare) > 0) Then
            MsgBox "the Assembly contains: " & fso.getbasename(odoc.Fullfilename) & " which is in the project folder. this macro will not be executed", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
            Exit Sub
        End If
    End If

    'Check no files are project files e.g.: 12887_07-100-000-A
    
    For Each refDoc In odoc.AllReferencedDocuments
        If InStr(1, refDoc.Fullfilename, invapp.FileLocations.Workspace) Then
            If Not (InStr(1, refDoc.Fullfilename, invapp.FileLocations.Workspace & "\Composantes\", vbTextCompare) > 0 Or _
                    InStr(1, refDoc.Fullfilename, invapp.FileLocations.Workspace & "\Pièces Client\", vbTextCompare) > 0) Then
                MsgBox "the Assembly contains: " & fso.getbasename(refDoc.Fullfilename) & " which is in the project folder. this macro will not be executed", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
                Exit Sub
            End If
        End If
    Next refDoc
    
    
    'lookup potential manufacturer
    Set matches = regex.Execute(odoc.DisplayName)
    
    If matches.count >= 1 Then
        potentialManufacturer = matches(0)
        'check if there is a folder already there for this manufacturer
        If fso.folderexists(ComposantesPath & potentialManufacturer) Then
            myPath = ComposantesPath & potentialManufacturer & "\"
        End If
        
    End If
    
    'Prompt user for where to save the file
    myFilePath = reuseLib.SaveMyFile("Create a folder where to save assembly", odoc.DisplayName, myPath)
    
    If myFilePath <> "" Then 'will be empty string if user cancels
    
        'Check folder was selected from Composantes directory
         If InStr(1, myFilePath, ComposantesPath, vbTextCompare) > 0 Then
            
            'change regex pattern to take folder from path
            regex.Pattern = ".*\\"
            
            Set matches = regex.Execute(myFilePath)
                Set myDir = fso.GetFolder(matches(0))
            If matches.count >= 1 Then
                
            Else
                MsgBox "folder detection error while using regex pattern .*\\ et le path: " & myFilePath, vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'Validate folder is not composantes directory itself
            If StrComp(myDir.Path, fso.GetFolder(ComposantesPath).Path, vbTextCompare) = 0 Then
                MsgBox "the assembly may not be created in the folder: " & myDir.Path & vbCrLf & "a sub-folder must be selected", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'Look for the selected manufacturer
            regex.Pattern = "(?:" & Replace(ComposantesPath, "\", "\\") & ")([^\\]*)"
            
            Set matches = regex.Execute(myDir.Path)
            
            If matches.count >= 1 Then
                IdentifiedManufacturer = UCase(matches(0).submatches(0))
            Else
                MsgBox "manufacturer not identified", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'if folder is empty then assume we place files there. Otherwise, we create a folder based on user input
            If myDir.subfolders.count > 0 Or myDir.Files.count > 0 Or _
                fso.getbasename(myFilePath) <> myDir.name Or _
                StrComp(Left(myDir.name, Len(IdentifiedManufacturer)), IdentifiedManufacturer, vbTextCompare) <> 0 Then
                
                ' If identified manufacturer is already part of the name, no need to insert it at the beginning of the path
                If StrComp(Left(fso.getbasename(myFilePath), Len(IdentifiedManufacturer)), IdentifiedManufacturer, vbTextCompare) = 0 Then
                    ProposedName = fso.getbasename(myFilePath)
                Else
                    ProposedName = IdentifiedManufacturer & "_" & fso.getbasename(myFilePath)
                End If
                
                myNewFolder = InputBox("Folder name", "Standard Assembly", ProposedName)
                
                If myNewFolder = "" Then 'user canceled
                    Exit Sub
                End If
                
                If Not myNewFolder = "" And Not fso.folderexists(myDir.Path & "\" & myNewFolder) Then
                    Set myDir = fso.createfolder(myDir.Path & "\" & myNewFolder)
                Else
                    Set myDir = fso.GetFolder(myDir.Path & "\" & myNewFolder)
                    If myDir.subfolders.count > 0 Or myDir.Files.count > 0 Then
                        MsgBox "le dossier: " & myDir.Path & "\" & myNewFolder & " existe déjà", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                        Exit Sub
                    End If
                End If
            End If
        
            'relativePath = Trim(Replace(oFileDialog.filename, ComposantesPath, "", 1, 1, vbTextCompare))
        Else
            MsgBox "Selected folder is not in the component root folder", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
            Exit Sub
        End If
    Else
        Exit Sub
    End If

Else
    MsgBox odoc.DisplayName & " is not an assembly or is already saved", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
    Exit Sub
End If


'validate each subdocument is a partdocument
For Each refDoc In odoc.AllReferencedDocuments
    If Not TypeOf refDoc Is PartDocument And Not TypeOf refDoc Is AssemblyDocument Then
        MsgBox "Assembly contains other files than sub-assemblies and parts", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
        Exit Sub
    End If
Next refDoc

savePath = myDir.Path & "\"
count = 0
ComponentName = myDir.name

'Update Assembly
If odoc.FileSaveCounter > 0 Then
    odoc.SaveAs savePath & ComponentName & ".iam", False
Else
    odoc.Fullfilename = savePath & ComponentName & ".iam"
End If

odoc.DisplayName = ComponentName


'count how many files already exists
For Each refDoc In odoc.AllReferencedDocuments
    If refDoc.FileSaveCounter > 0 Then
        FiletoCopyCount = FiletoCopyCount + 1
    End If
Next refDoc

If FiletoCopyCount > 0 Then
    Set progBar = invapp.CreateProgressBar(False, FiletoCopyCount, "Copying components ...", False)
End If

'redo reference of all sub components
For Each refDoc In odoc.AllReferencedDocuments

    If TypeOf refDoc Is PartDocument Then
        fileExtension = ".ipt"
    ElseIf TypeOf refDoc Is AssemblyDocument Then
        fileExtension = ".iam"
    End If
    'increment part suffix (e.g.: XXXXX_1, XXXXX_2, etc...)
    count = count + 1
    
    newFullFileName = savePath & ComponentName & "_" & count & fileExtension
    
    'if file already exists, make a new one based on the first
    If refDoc.FileSaveCounter > 0 Then
        progBar.Message = refDoc.Fullfilename & " --> " & newFullFileName
        'copy file once, reuse then
        If Not fso.fileExists(newFullFileName) Then
            fso.CopyFile refDoc.Fullfilename, newFullFileName, False '.CopyFile(Source, Dest [,Overwrite (True/False)]
        End If
        Set DocDescriptor = odoc.ReferencedDocumentDescriptors.item(refDoc.Fullfilename)
        DocDescriptor.ReferencedFileDescriptor.ReplaceReference newFullFileName
        progBar.UpdateProgress
    Else
        'Change file name to desired location
        refDoc.Fullfilename = newFullFileName
    End If
    
    'Change document display name
    refDoc.DisplayName = ComponentName & "_" & count
Next refDoc

If Not progBar Is Nothing Then
    progBar.Close
End If


'update browser
BrowserNodeUpdate

'Set a progress bar so user understands he has to wait
Set progBar = invapp.CreateProgressBar(False, 1, "Sauvegarde en cours", False)
progBar.UpdateProgress
'Save all documents to new location
odoc.Save2 True
progBar.UpdateProgress
progBar.Close

Set myDir = Nothing

StandardAssemblyErr:
If Err Then
    MsgBox "Unexpected error during StandardAssembly routine: " & Err.Description, Title:="Standard Assembly"
    Err.Clear
    If Not progBar Is Nothing Then
        progBar.Close
    End If
End If
End Sub

Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As LongPtr
    ' EX: Call reuseLib.ShellExecute(Application.hwnd, "printto", strPathAndFilename, "my printer name", vbNullString, 0)
    
    
'#If VBA7 Then
    Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
      
    Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type
  
  Public Enum OFN_FLAGS
  OFN_ALLOWMULTISELECT = &H200
  OFN_CREATEPROMPT = &H2000
  OFN_DONTADDTORECENT = &H2000000
  OFN_ENABLEHOOK = &H20
  OFN_ENABLEINCLUDENOTIFY = &H400000
  OFN_ENABLESIZING = &H800000
  OFN_ENABLETEMPLATE = &H40
  OFN_ENABLETEMPLATEHANDLE = &H80
  OFN_EXPLORER = &H80000
  OFN_EXTENSIONDIFFERENT = &H400
  OFN_FILEMUSTEXIST = &H1000
  OFN_FORCESHOWHIDDEN = &H10000000
  OFN_HIDEREADONLY = &H4
  OFN_LONGNAMES = &H200000
  OFN_NOCHANGEDIR = &H8
  OFN_NODEREFERENCELINKS = &H100000
  OFN_NOLONGNAMES = &H40000
  OFN_NONETWORKBUTTON = &H20000
  OFN_NOREADONLYRETURN = &H8000
  OFN_NOTESTFILECREATE = &H10000
  OFN_NOVALIDATE = &H100
  OFN_OVERWRITEPROMPT = &H2
  OFN_PATHMUSTEXIST = &H800
  OFN_READONLY = &H1
  OFN_SHAREAWARE = &H4000
  OFN_SHOWHELP = &H10
End Enum

Const OFN_DefaultOpenFlags = OFN_EXPLORER + OFN_LONGNAMES + OFN_HIDEREADONLY + _
    OFN_DONTADDTORECENT + OFN_ENABLESIZING + OFN_NOCHANGEDIR + OFN_PATHMUSTEXIST + _
    OFN_FILEMUSTEXIST
Const OFN_DefaultSaveFlags = OFN_EXPLORER + OFN_LONGNAMES + OFN_HIDEREADONLY + _
    OFN_DONTADDTORECENT + OFN_ENABLESIZING + OFN_NOCHANGEDIR + OFN_PATHMUSTEXIST + _
    OFN_OVERWRITEPROMPT

'/////////////////////////////////
'// End code GetOpenFileName    //
'/////////////////////////////////

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modBrowseFolder
' This contains the BrowseFolder function, which displays the standard Windows Browse For Folder
' dialog. It return the complete path of the selected folder or vbNullString if the user cancelled.
' It also contains the function BrowseFolderExplorer which presents the user with a Windows
' Explorer-like interface to pick the folder.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_EDITBOX As Long = &H10


    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type


Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
    ByVal pszBuffer As String) As Long

Private Declare PtrSafe Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
    BROWSEINFO) As Long


Private Const MAX_PATH = 260 ' Windows mandated

Public Function SaveMyFile(strTitle As String, strFileName As String, strPath As String) As String

    Dim OpenFile    As OPENFILENAME
    Dim lReturn     As Long
    Dim boolReturn As Boolean
    
    Dim buff As String * 256
    buff = strFileName
    
   
    
    OpenFile.lpstrFilter = "Inventor Files (*.iam;*.ipt)|*.iam;*.ipt|All Files (*.*)|*.*"
    OpenFile.nFilterIndex = 1
    OpenFile.hwndOwner = 0
    OpenFile.lpstrFile = buff 'String(257, 0)
    #If VBA7 Then
        OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = LenB(OpenFile)
    #Else
        OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = Len(OpenFile)
    #End If
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = strPath
    OpenFile.lpstrTitle = strTitle
    OpenFile.flags = 0
    boolReturn = GetSaveFileName(OpenFile)
  
    If Not boolReturn Then
        SaveMyFile = ""
    Else
        SaveMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If
  
End Function

This code force folder to be in a given folder group. you will need to change that part and also the part where I ask the user to select the folder and location

Good luck !

Anonymous · ‎12-03-2020

hi,

it is not working

yan.gauthier · ‎12-03-2020

Hi,

This is VBA not iLogic. which part does not work ?

Also this macro needs to be called from an assembly

yan.gauthier · ‎12-03-2020

This code comes from several modules of mine. I reassembled the code so it works.

StandardAssembly is the main macro here. You need to change it to works since it is looking for specific folders which are part of my companies structure.

Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As LongPtr
    ' EX: Call reuseLib.ShellExecute(Application.hwnd, "printto", strPathAndFilename, "my printer name", vbNullString, 0)
    
    
'#If VBA7 Then
    Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
      
    Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type
  
  Public Enum OFN_FLAGS
  OFN_ALLOWMULTISELECT = &H200
  OFN_CREATEPROMPT = &H2000
  OFN_DONTADDTORECENT = &H2000000
  OFN_ENABLEHOOK = &H20
  OFN_ENABLEINCLUDENOTIFY = &H400000
  OFN_ENABLESIZING = &H800000
  OFN_ENABLETEMPLATE = &H40
  OFN_ENABLETEMPLATEHANDLE = &H80
  OFN_EXPLORER = &H80000
  OFN_EXTENSIONDIFFERENT = &H400
  OFN_FILEMUSTEXIST = &H1000
  OFN_FORCESHOWHIDDEN = &H10000000
  OFN_HIDEREADONLY = &H4
  OFN_LONGNAMES = &H200000
  OFN_NOCHANGEDIR = &H8
  OFN_NODEREFERENCELINKS = &H100000
  OFN_NOLONGNAMES = &H40000
  OFN_NONETWORKBUTTON = &H20000
  OFN_NOREADONLYRETURN = &H8000
  OFN_NOTESTFILECREATE = &H10000
  OFN_NOVALIDATE = &H100
  OFN_OVERWRITEPROMPT = &H2
  OFN_PATHMUSTEXIST = &H800
  OFN_READONLY = &H1
  OFN_SHAREAWARE = &H4000
  OFN_SHOWHELP = &H10
End Enum

Const OFN_DefaultOpenFlags = OFN_EXPLORER + OFN_LONGNAMES + OFN_HIDEREADONLY + _
    OFN_DONTADDTORECENT + OFN_ENABLESIZING + OFN_NOCHANGEDIR + OFN_PATHMUSTEXIST + _
    OFN_FILEMUSTEXIST
Const OFN_DefaultSaveFlags = OFN_EXPLORER + OFN_LONGNAMES + OFN_HIDEREADONLY + _
    OFN_DONTADDTORECENT + OFN_ENABLESIZING + OFN_NOCHANGEDIR + OFN_PATHMUSTEXIST + _
    OFN_OVERWRITEPROMPT

'/////////////////////////////////
'// End code GetOpenFileName    //
'/////////////////////////////////

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modBrowseFolder
' This contains the BrowseFolder function, which displays the standard Windows Browse For Folder
' dialog. It return the complete path of the selected folder or vbNullString if the user cancelled.
' It also contains the function BrowseFolderExplorer which presents the user with a Windows
' Explorer-like interface to pick the folder.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_EDITBOX As Long = &H10


    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type


Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
    ByVal pszBuffer As String) As Long

Private Declare PtrSafe Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
    BROWSEINFO) As Long


Private Const MAX_PATH = 260 ' Windows mandated

Private Sub BrowserNameUpdate(oComponent As ComponentOccurrence, oBrowserPane As BrowserPane)

Dim oNodeDefinition As BrowserNodeDefinition
Dim Occurrence As String
Dim ComponentName As String
Dim oNode As BrowserNode
Dim ComponentFileName As String
Dim NodeName As String
Dim fso As Object
Dim OccurrenceDict As Object
Dim count As Integer: count = 0
Dim oOccurrences As ComponentOccurrences
Dim oSubOccurrence As ComponentOccurrence
Dim oSubOccurrences As ComponentOccurrencesEnumerator
Dim DocName As String
Dim oComponentOccurrenceToRename As ComponentOccurrence
Dim oOccurrenceProxy As ComponentOccurrenceProxy
Dim i As Integer
Dim pos As Integer

Dim randomNumber As Long

On Error GoTo BrowserNameUpdateErr

Set OccurrenceDict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")

 'Loop through each component in the three view
For Each oSubOccurrence In oComponent.SubOccurrences
    'Skip welds if in a weldment
    If Not TypeOf oSubOccurrence.Definition Is WeldsComponentDefinition Then
        Set oNode = oBrowserPane.GetBrowserNodeFromObject(oSubOccurrence)
        Set oNodeDefinition = oNode.BrowserNodeDefinition
        
        ComponentFileName = fso.getbasename(oSubOccurrence.Definition.Document.FullFileName)

        'Get node name without occurence
        If InStr(1, oNodeDefinition.Label, ":") > 0 Then
            NodeName = Left(oNodeDefinition.Label, InStrRev(oNodeDefinition.Label, ":") - 1)
        Else
            'Set nodename the same as componentFilename to pass over
            NodeName = oNodeDefinition.Label
        End If
        'Compare browser label with occurrence name
        If NodeName <> ComponentFileName Then
            Set oSubOccurrences = oComponent.Definition.Occurrences.AllReferencedOccurrences(oSubOccurrence.Definition.Document)
            
            'Prepare random number between 100000 and 1000
            randomNumber = Int((100000 - 1000 + 1) * Rnd + 1000)
            
            'Check if occurrences is present more than once
            For i = 1 To oSubOccurrences.count
                'Give a random occurrence value between 100000 and 1000
                pos = 1
                oSubOccurrences(i).Name = NodeName & (randomNumber + i)
            Next i
            
            For i = 1 To oSubOccurrences.count
                'Give an ordered value
                pos = 2
                oSubOccurrences(i).Name = ComponentFileName & ":" & i
            Next i
            pos = 3

        End If
 
        'Recursively call this sub for sub assembly
        If TypeOf oComponent.Definition.Document Is AssemblyDocument Then
            BrowserNameUpdate oSubOccurrence, oBrowserPane
        End If
    End If
        
    
Next oSubOccurrence

BrowserNameUpdateErr:

If Err Then
    MsgBox "Unexpected Error: " & Err.Description, vbMsgBoxSetForeground, "BrowserNameUpdate"
    Err.Clear
End If

End Sub

Sub BrowserNodeUpdate()
  
Dim invapp As Inventor.Application
Dim odoc As Document
Dim oAssemblyDoc As AssemblyDocument
Dim oPartDoc As PartDocument
Dim oComponentOccurrence As ComponentOccurrence
Dim oNode As BrowserNode
Dim oNodeDefinition As BrowserNodeDefinition
Dim sOccurrence As String
Dim oOccurrences As ComponentOccurrencesEnumerator
Dim ComponentName As String
Dim oBrowserPane As BrowserPane
Dim DocName As String
Dim fso As Object
Dim ComponentFileName As String
Dim OccurrenceDict As Object
Dim NodeName As String
Dim oComponentOccurrenceToRename As ComponentOccurrence
Dim i As Integer


On Error GoTo BrowserNodeUpdateErr

Set invapp = ThisApplication
Set odoc = invapp.ActiveDocument
Set fso = CreateObject("Scripting.FileSystemObject")
Set OccurrenceDict = CreateObject("Scripting.Dictionary")
'Get to the Model Browser tree view on the active assembly
If TypeOf odoc Is AssemblyDocument Then
    Set oAssemblyDoc = odoc
    Set oBrowserPane = oAssemblyDoc.BrowserPanes.Item("Model")
        
    For Each oComponentOccurrence In oAssemblyDoc.ComponentDefinition.Occurrences
        'Skip welds if in a weldment
       If Not TypeOf oComponentOccurrence.Definition Is WeldsComponentDefinition Then
            Set oNode = oBrowserPane.GetBrowserNodeFromObject(oComponentOccurrence)
            Set oNodeDefinition = oNode.BrowserNodeDefinition
      
            ComponentFileName = fso.getbasename(oComponentOccurrence.Definition.Document.FullFileName)

            
            'Get node name without occurence
            If InStr(1, oNodeDefinition.Label, ":") > 0 Then
                NodeName = Left(oNodeDefinition.Label, InStrRev(oNodeDefinition.Label, ":") - 1)
            Else
                'Set nodename the same as componentFilename to pass over
                NodeName = oNodeDefinition.Label
            End If
            'Compare browser label with occurrence name
            If NodeName <> ComponentFileName Then
            
                'Check if occurrences is present more than once
                Set oOccurrences = oAssemblyDoc.ComponentDefinition.Occurrences.AllReferencedOccurrences(oComponentOccurrence.Definition.Document)
                For i = 1 To oOccurrences.count
                    'Give a random occurrence value between 10000 and 1000
                    oOccurrences(i).Name = NodeName & Int((10000 - 1000 + 1) * Rnd + 1000)
                Next i
                
                For i = 1 To oOccurrences.count
                    'Give a random occurrence value between 10000 and 1000
                    oOccurrences(i).Name = ComponentFileName & ":" & i
                Next i

            End If

            'Recursively call this sub for sub assembly
            If TypeOf oComponentOccurrence.Definition.Document Is AssemblyDocument Then
                BrowserNameUpdate oComponentOccurrence, oBrowserPane
            End If
        End If
    Next oComponentOccurrence
    oBrowserPane.Refresh
    oBrowserPane.Update
    'BrowserNameUpdate oAssemblyDoc.BrowserPanes.item("Model").TopNode, False
          
End If

BrowserNodeUpdateErr:
If Err Then
    MsgBox "Unexpected Error: " & Err.Description, vbMsgBoxSetForeground, "BrowserNodeUpdate"
    Err.Clear
End If

End Sub

Sub StandardAssembly()

Dim invapp As Inventor.Application
Dim odoc As Document
Dim refDoc As Document
Dim savePath As String
Dim ComponentName As String
Dim count As Integer
Dim partDoc As PartDocument
Dim progBar As ProgressBar
Dim regex As Object
Dim ComposantesPath As String
Dim myDir As Object
Dim myPath As String
Dim Manufacturer As String
Dim fso As Object
Dim myFilePath As String
Dim myNewFolder As String
Dim matches As Object
Dim potentialManufacturer As String
Dim fileExtension As String
Dim FileDesc As FileDescriptor
Dim newFullFileName As String
Dim DocDescriptor As DocumentDescriptor
Dim FiletoCopyCount As Integer: FiletoCopyCount = 0
Dim IdentifiedManufacturer As String
Dim ProposedName As String

Set regex = CreateObject("vbscript.RegExp")
regex.Pattern = "[^_]*" 'Search groups of digits
'[^     begin exclude group
'_      match this character
']      end of exclude group
'*      match exeption any number of times

regex.Global = False 'end after first match

Set fso = CreateObject("Scripting.FileSystemObject")

Set invapp = ThisApplication
Set odoc = invapp.ActiveEditDocument

' Set up composantes directory
ComposantesPath = invapp.FileLocations.Workspace & "\Composantes\"
myPath = ComposantesPath

'Flatten All
If TypeOf odoc Is AssemblyDocument Then
    'Check Assembly is not saved in project directory
    If InStr(1, odoc.FullFileName, invapp.FileLocations.Workspace) Then 'first check is to allow assembly from outside project directory e.g.: download folder.
        If Not (InStr(1, odoc.FullFileName, invapp.FileLocations.Workspace & "\Composantes\", vbTextCompare) > 0 Or _
                InStr(1, odoc.FullFileName, invapp.FileLocations.Workspace & "\Pièces Client\", vbTextCompare) > 0) Then
            MsgBox "the Assembly contains: " & fso.getbasename(odoc.FullFileName) & " which is in the project folder. this macro will not be executed", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
            Exit Sub
        End If
    End If

    'Check no files are project files e.g.: 12887_07-100-000-A
    
    For Each refDoc In odoc.AllReferencedDocuments
        If InStr(1, refDoc.FullFileName, invapp.FileLocations.Workspace) Then
            If Not (InStr(1, refDoc.FullFileName, invapp.FileLocations.Workspace & "\Composantes\", vbTextCompare) > 0 Or _
                    InStr(1, refDoc.FullFileName, invapp.FileLocations.Workspace & "\Pièces Client\", vbTextCompare) > 0) Then
                MsgBox "the Assembly contains: " & fso.getbasename(refDoc.FullFileName) & " which is in the project folder. this macro will not be executed", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
                Exit Sub
            End If
        End If
    Next refDoc
    
    
    'lookup potential manufacturer
    Set matches = regex.Execute(odoc.DisplayName)
    
    If matches.count >= 1 Then
        potentialManufacturer = matches(0)
        'check if there is a folder already there for this manufacturer
        If fso.folderexists(ComposantesPath & potentialManufacturer) Then
            myPath = ComposantesPath & potentialManufacturer & "\"
        End If
        
    End If
    
    'Prompt user for where to save the file
    myFilePath = SaveMyFile("Create a folder where to save assembly", odoc.DisplayName, myPath)
    
    If myFilePath <> "" Then 'will be empty string if user cancels
    
        'Check folder was selected from Composantes directory
         If InStr(1, myFilePath, ComposantesPath, vbTextCompare) > 0 Then
            
            'change regex pattern to take folder from path
            regex.Pattern = ".*\\"
            
            Set matches = regex.Execute(myFilePath)
                Set myDir = fso.GetFolder(matches(0))
            If matches.count >= 1 Then
                
            Else
                MsgBox "folder detection error while using regex pattern .*\\ et le path: " & myFilePath, vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'Validate folder is not composantes directory itself
            If StrComp(myDir.Path, fso.GetFolder(ComposantesPath).Path, vbTextCompare) = 0 Then
                MsgBox "the assembly may not be created in the folder: " & myDir.Path & vbCrLf & "a sub-folder must be selected", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'Look for the selected manufacturer
            regex.Pattern = "(?:" & Replace(ComposantesPath, "\", "\\") & ")([^\\]*)"
            
            Set matches = regex.Execute(myDir.Path)
            
            If matches.count >= 1 Then
                IdentifiedManufacturer = UCase(matches(0).submatches(0))
            Else
                MsgBox "manufacturer not identified", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                Exit Sub
            End If
            
            'if folder is empty then assume we place files there. Otherwise, we create a folder based on user input
            If myDir.subfolders.count > 0 Or myDir.Files.count > 0 Or _
                fso.getbasename(myFilePath) <> myDir.Name Or _
                StrComp(Left(myDir.Name, Len(IdentifiedManufacturer)), IdentifiedManufacturer, vbTextCompare) <> 0 Then
                
                ' If identified manufacturer is already part of the name, no need to insert it at the beginning of the path
                If StrComp(Left(fso.getbasename(myFilePath), Len(IdentifiedManufacturer)), IdentifiedManufacturer, vbTextCompare) = 0 Then
                    ProposedName = fso.getbasename(myFilePath)
                Else
                    ProposedName = IdentifiedManufacturer & "_" & fso.getbasename(myFilePath)
                End If
                
                myNewFolder = InputBox("Folder name", "Standard Assembly", ProposedName)
                
                If myNewFolder = "" Then 'user canceled
                    Exit Sub
                End If
                
                If Not myNewFolder = "" And Not fso.folderexists(myDir.Path & "\" & myNewFolder) Then
                    Set myDir = fso.createfolder(myDir.Path & "\" & myNewFolder)
                Else
                    Set myDir = fso.GetFolder(myDir.Path & "\" & myNewFolder)
                    If myDir.subfolders.count > 0 Or myDir.Files.count > 0 Then
                        MsgBox "le dossier: " & myDir.Path & "\" & myNewFolder & " existe déjà", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
                        Exit Sub
                    End If
                End If
            End If
        
            'relativePath = Trim(Replace(oFileDialog.filename, ComposantesPath, "", 1, 1, vbTextCompare))
        Else
            MsgBox "Selected folder is not in the component root folder", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
            Exit Sub
        End If
    Else
        Exit Sub
    End If

Else
    MsgBox odoc.DisplayName & " is not an assembly or is already saved", vbExclamation + vbMsgBoxSetForeground, "Standard Assembly"
    Exit Sub
End If


'validate each subdocument is a partdocument
For Each refDoc In odoc.AllReferencedDocuments
    If Not TypeOf refDoc Is PartDocument And Not TypeOf refDoc Is AssemblyDocument Then
        MsgBox "Assembly contains other files than sub-assemblies and parts", vbExclamation + vbMsgBoxSetForeground, "StandardAssembly"
        Exit Sub
    End If
Next refDoc

savePath = myDir.Path & "\"
count = 0
ComponentName = myDir.Name

'Update Assembly
If odoc.FileSaveCounter > 0 Then
    odoc.SaveAs savePath & ComponentName & ".iam", False
Else
    odoc.FullFileName = savePath & ComponentName & ".iam"
End If

odoc.DisplayName = ComponentName


'count how many files already exists
For Each refDoc In odoc.AllReferencedDocuments
    If refDoc.FileSaveCounter > 0 Then
        FiletoCopyCount = FiletoCopyCount + 1
    End If
Next refDoc

If FiletoCopyCount > 0 Then
    Set progBar = invapp.CreateProgressBar(False, FiletoCopyCount, "Copying components ...", False)
End If

'redo reference of all sub components
For Each refDoc In odoc.AllReferencedDocuments

    If TypeOf refDoc Is PartDocument Then
        fileExtension = ".ipt"
    ElseIf TypeOf refDoc Is AssemblyDocument Then
        fileExtension = ".iam"
    End If
    'increment part suffix (e.g.: XXXXX_1, XXXXX_2, etc...)
    count = count + 1
    
    newFullFileName = savePath & ComponentName & "_" & count & fileExtension
    
    'if file already exists, make a new one based on the first
    If refDoc.FileSaveCounter > 0 Then
        progBar.Message = refDoc.FullFileName & " --> " & newFullFileName
        'copy file once, reuse then
        If Not fso.fileExists(newFullFileName) Then
            fso.CopyFile refDoc.FullFileName, newFullFileName, False '.CopyFile(Source, Dest [,Overwrite (True/False)]
        End If
        Set DocDescriptor = odoc.ReferencedDocumentDescriptors.Item(refDoc.FullFileName)
        DocDescriptor.ReferencedFileDescriptor.ReplaceReference newFullFileName
        progBar.UpdateProgress
    Else
        'Change file name to desired location
        refDoc.FullFileName = newFullFileName
    End If
    
    'Change document display name
    refDoc.DisplayName = ComponentName & "_" & count
Next refDoc

If Not progBar Is Nothing Then
    progBar.Close
End If


'update browser
BrowserNodeUpdate

'Set a progress bar so user understands he has to wait
Set progBar = invapp.CreateProgressBar(False, 1, "Sauvegarde en cours", False)
progBar.UpdateProgress
'Save all documents to new location
odoc.Save2 True
progBar.UpdateProgress
progBar.Close

Set myDir = Nothing

StandardAssemblyErr:
If Err Then
    MsgBox "Unexpected error during StandardAssembly routine: " & Err.Description, Title:="Standard Assembly"
    Err.Clear
    If Not progBar Is Nothing Then
        progBar.Close
    End If
End If
End Sub



Public Function SaveMyFile(strTitle As String, strFileName As String, strPath As String) As String

    Dim OpenFile    As OPENFILENAME
    Dim lReturn     As Long
    Dim boolReturn As Boolean
    
    Dim buff As String * 256
    buff = strFileName
    
   
    
    OpenFile.lpstrFilter = "Inventor Files (*.iam;*.ipt)|*.iam;*.ipt|All Files (*.*)|*.*"
    OpenFile.nFilterIndex = 1
    OpenFile.hwndOwner = 0
    OpenFile.lpstrFile = buff 'String(257, 0)
    #If VBA7 Then
        OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = LenB(OpenFile)
    #Else
        OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = Len(OpenFile)
    #End If
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = strPath
    OpenFile.lpstrTitle = strTitle
    OpenFile.flags = 0
    boolReturn = GetSaveFileName(OpenFile)
  
    If Not boolReturn Then
        SaveMyFile = ""
    Else
        SaveMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If
  
End Function

Regards,

Anonymous · ‎12-03-2020

I have a master assembly that contain some library parts & some customized part. I need a iLogic / vb code to open master assemble in other project, then SaveAs its customized part in that project except library component.

Can you please help

yan.gauthier · ‎12-04-2020

With that code, you have plenty enough to build something that will do exactly what you need.

Anonymous · ‎12-11-2020

hi,

while using these vba code it is showing error "unexpected error :Method 'Name'' of object ' ComponentOccurence' failed"

Save and Replace component and subcomponent

Save and Replace component and subcomponent

Forums Links

Post to forums