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?
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
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.
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 !
Hi,
This is VBA not iLogic. which part does not work ?
Also this macro needs to be called from an assembly
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,
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
With that code, you have plenty enough to build something that will do exactly what you need.
hi,
while using these vba code it is showing error "unexpected error :Method 'Name'' of object ' ComponentOccurence' failed"
Can't find what you're looking for? Ask the community or share your knowledge.