Hi all,
I'm here again with an issue during updating my inventor to 2018
We're using a module in the VBA that allows us to automaticly 'makeAllFreeAndPromote" an assembly when you drag and drop this.
In 2016 this works perfect, in 2018 not.
Let me explain what I want to do:
1. drag and drop an assembly from our library in my project (on toplevel)
2. explode this imported assembly into the separate parts and delete the imported assembly.
In 2018 this happens:
1. Drag and drop the assembly works fine
2. explode the assembly into separate parts works fine
3. Delete the imported assembly doesn't works anymore.
Please help me out how I can fix this.
Because, when I save my project - it also saves the empty assembly.
See screenshot below.
Here is the code:
Module 1 = auto make all free and promote
Sub AutoMakeAllFreePromote()
'step 1 Check if the correct Workspace is set
Call GetFileLocation
Dim oWorkspace As String
oWorkspace = ThisApplication.DesignProjectManager.ActiveDesignProject.WorkspacePath
If oWorkspace <> sDefaultRootProject Then
Debug.Print "Rule AutoMakeAllFreePromote has been cancelled because non-default workspace has been chosen"
Debug.Print "This is normal if you are editing beCAD"
Exit Sub
End If
'step 2 Determine the level we are one
Dim oMainAssembly As AssemblyDocument
Set oMainAssembly = ThisApplication.ActiveDocument
Dim oAssembly As AssemblyDocument
Set oAssembly = ThisApplication.ActiveEditDocument
Dim oOcc As ComponentOccurrence
'step 3 select the part that has been placed & edit it
If oMainAssembly.FullDocumentName = oAssembly.FullDocumentName Then
'we are on the main assembly
Set oOcc = oAssembly.ComponentDefinition.Occurrences.Item(oAssembly.ComponentDefinition.Occurrences.Count)
Else
'we are in a subassembly
MsgBox "Move this assembly to the Main assembly & press 'MakeAllFreeAndPromote'. Next time place directly at top level", vbOKOnly, "Error"
Exit Sub
'the below doesn't work properly, to be investigated
'Set oOcc = oMainAssembly.ComponentDefinition.Occurrences.ItemByName(oMainAssembly.ComponentDefinition.ActiveOccurrence.Name).SubOccurrences.Item(oAssembly.ComponentDefinition.Occurrences.Count)
End If
oOcc.Edit
'step 3 Call MakeAllFreeAndPromote
MakeAlleFreeAndPromote
End SubModule 2 = make all free and promote
Public Sub MakeAlleFreeAndPromote()
' Create a transaction. -> for 1 undo command
Dim oTransMgr As TransactionManager
Set oTransMgr = ThisApplication.TransactionManager
Dim oTrans As Transaction
Set oTrans = oTransMgr.StartTransaction(ThisApplication.ActiveDocument, "MakeAlleFreeAndPromote")
' check if an iwall is selected
Dim oDoc As AssemblyDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oOcc As ComponentOccurrence
On Error Resume Next
Set oOcc = oDoc.SelectSet.Item(1)
If Err Then
GoTo TraverseNormally
End If
If oOcc.DefinitionDocumentType = kAssemblyDocumentObject Then
If oOcc.ActiveLevelOfDetailRepresentation = "Wall" Then
oOcc.Edit
End If
End If
'declare everything needed
TraverseNormally:
Dim oDef As AssemblyComponentDefinition
Set oDef = oDoc.ComponentDefinition
Dim oAssDoc As AssemblyDocument
Set oAssDoc = ThisApplication.ActiveEditObject
Dim oActDef As AssemblyComponentDefinition
Set oActDef = oAssDoc.ComponentDefinition
Dim oPattern As OccurrencePattern
Dim oPatternElement As OccurrencePatternElement
Dim oOccurence As ComponentOccurrence
Dim oComponent As ComponentOccurrence
'Traverse all the patterns in the assembly:
For Each oPattern In oAssDoc.ComponentDefinition.OccurrencePatterns
'Traverse all elements in the pattern to make them independent:
For Each oPatternElement In oPattern.OccurrencePatternElements
' On Error Resume Next
oPatternElement.Independent = True
If Err Then
Err.Clear
End If
Next oPatternElement
Next oPattern
'Delete all patterns in the assembly
For Each oPattern In oAssDoc.ComponentDefinition.OccurrencePatterns
oPattern.Delete
Next oPattern
'delete all suppressed
For Each oComponent In oAssDoc.ComponentDefinition.Occurrences
If oComponent.Suppressed = True Then
oComponent.Delete
End If
Next oComponent
'Unground all components
For Each oOccurence In oAssDoc.ComponentDefinition.Occurrences
If oOccurence.Grounded = True Then
oOccurence.Grounded = False
End If
Next oOccurence
'Delete all iComposites
For Each oIcomp In oAssDoc.ComponentDefinition.iMateResults
' On Error Resume Next
oIcomp.Delete
If Err Then
Err.Clear
End If
Next oIcomp
'Delete all imates
For Each oImate In oAssDoc.ComponentDefinition.iMateDefinitions
' On Error Resume Next
oImate.Delete
If Err Then
Err.Clear
End If
Next oImate
'Delete all constraints
For Each oConstraint In oAssDoc.ComponentDefinition.Constraints
' On Error Resume Next
oConstraint.Delete
If Err Then
Err.Clear
End If
Next oConstraint
'Promote all frames
' Get the top level occurrence of an assembly
Dim oSubAssyOcc As ComponentOccurrence
' On Error Resume Next
Set oSubAssyOcc = oDef.Occurrences.ItemByName(oDef.ActiveOccurrence.Name)
'If Err Then
' MsgBox "A subassembly must be active if you want to promote it. No Subassembly will be touched"
' Else
Dim i As Integer
For i = 1 To oActDef.Occurrences.Count
' Get the 2nd level occurrence under the assembly occurrence
Dim oSubOcc As ComponentOccurrenceProxy
Set oSubOcc = oSubAssyOcc.SubOccurrences.Item(1)
Dim oPane As BrowserPane
Set oPane = oDoc.BrowserPanes.Item("AmBrowserArrangement") '2017 11 05 - multilangue change
' Get the browser nodes corresponding to the two occurrences
Dim oTargetNode As BrowserNode
Set oTargetNode = oPane.GetBrowserNodeFromObject(oSubAssyOcc)
Dim oSourceNode As BrowserNode
Set oSourceNode = oPane.GetBrowserNodeFromObject(oSubOcc)
' Reorder the nodes to promote the sub-occurrence to the top level
Call oPane.Reorder(oTargetNode, True, oSourceNode)
Next
' activate one level up
Dim oCtrlDef As ControlDefinition
Set oCtrlDef = ThisApplication.CommandManager.ControlDefinitions.Item("AppReturnTopCmd")
oCtrlDef.Execute
' Delete the original Subassembly
oSubAssyOcc.Delete
oSubAssyOcc.Delete
'End If
On Error GoTo 0
' End the transaction.
oTrans.End
End Sub
