Community
Krieg,
See image, I am trying to add these features to 'oObjColl' but without success.
Would you please point me in the right direction?
I've tried the following your trend to add the Sketches, please find the pieces of code attached followed by the complete code.
At some point the function 'GetBend' recognizes a 'kBendFeatureObject' but then the value 'oNode.NativeObject' is not passed in 'Set GetBend'.
As far as 'Corner' is concerned, I miss the 'NativeObject' completely while I do see it in the list of items.
Where are things going wrong?
Thanks in advance.
Dim oBend As BendOptions
Set oBend = GetBend(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oBend Is Nothing Then
Call oObjColl.Add(oBend)
End If
Dim oCorner As CornerOptions
Set oCorner = GetCorner(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oCorner Is Nothing Then
Call oObjColl.Add(oCorner)
End If
Private Function GetBend(ByVal oNodes As BrowserNodesEnumerator) As BendOptions
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
'MsgBox oNode.NativeObject.Name
If oNode.NativeObject.Type = kBendFeatureObject Then
Set GetBend = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Private Function GetCorner(ByVal oNodes As BrowserNodesEnumerator) As CornerOptions
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
If oNode.NativeObject.Type = kCornerOptionsObject Then
Set GetCorner = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Option Explicit
Private Const sEOP As String = "End of Features"
Private Const sEOF As String = "End of Features"
'Private Const sEOP As String = "End Of Part"
Private Const sConstraints As String = "Constraints"
Private Const siMates As String = "iMates" 'iMates
Private Const sRepresentations As String = "Representations"
Private Const sOrigin As String = "Origin"
Private Const sPosRep As String = "PositionalRepresentations"
Private Const sBlocks As String = "Blocks"
Private Const sSurfaceBodies As String = "SurfaceBodies"
Private Const sWorkSurfaces As String = "WorkSurfaces"
Private Const sDesignView As String = "DesignView:"
'Private Const sEOP As String = "Elementenende" '"End of Features"
'Private Const sEOF As String = "Elementenende" 'End of Features
''Private Const sEOP As String = "Bauteilende" 'EndOfPart
'Private Const sConstraints As String = "Beziehungen" 'Constraints
'Private Const siMates As String = "iMates" 'iMates
'Private Const sRepresentations As String = "Darstellungen" 'Representations
'Private Const sOrigin As String = "Ursprung" 'Origin
'Private Const sPosRep As String = "Positionsdarstellungen" 'PositionalRepresentations
'Private Const sBlocks As String = "Blöcke" 'Blocks
'Private Const sSurfaceBodies As String = "Volumenkörper(" 'SurfaceBodies(
'Private Const sWorkSurfaces As String = "Flächenkörper(" 'WorkSurfaces
'Private Const sDesignView As String = "Ansicht:" 'DesignView:
Public Sub Sort_Browser_KR()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim oDoc As Document
Dim oPartDoc As PartDocument
Dim oAssDoc As AssemblyDocument
If oApp.ActiveDocumentType = kAssemblyDocumentObject Then
Set oAssDoc = oApp.ActiveDocument
Call ProcessAssBrowserPane(oAssDoc)
For Each oDoc In oAssDoc.AllReferencedDocuments
If oDoc.DocumentType = kPartDocumentObject Then
Call ProcessPartBrowserPane(oDoc)
ElseIf oDoc.DocumentType = kAssemblyDocumentObject Then
Call ProcessAssBrowserPane(oDoc)
End If
Next
ElseIf oApp.ActiveDocumentType = kPartDocumentObject Then
Set oPartDoc = oApp.ActiveDocument
Call ProcessPartBrowserPane(oPartDoc)
Else
MsgBox ("Part or Assembly, nothing else.")
End If
End Sub
Private Sub ProcessPartBrowserPane(ByVal oPartDoc As PartDocument)
If oPartDoc.FullFileName Like "*Bieb HML*" Then Exit Sub
'If the "ContentCenter" property set exists, the part came from Content Center
Dim IsCCPart As String
IsCCPart = oPartDoc.PropertySets.PropertySetExists("ContentCenter")
''MsgBox oPartDoc.DisplayName & "Is Content Center Part: " & IsCCPart
If IsCCPart = "True" Then Exit Sub
'Detect if Assembly/Part is Locked/Content Center 'By CheckMaster
If oPartDoc.ComponentDefinition.IsContentMember = True Then Exit Sub
'MsgBox oPartDoc.ComponentDefinition.IsContentMember '' = False Then
'Detect if Assembly/Part is Is Modifiable 'By CheckMaster
'MsgBox oPartDoc.IsModifiable
If oPartDoc.IsModifiable = False Then Exit Sub
' Did not work...
'Detect if Assembly/Part is Read Only 'By CheckMaster
'If oPartDoc.ComponentDefinition.IsContentMember = True Then Exit Sub
'MsgBox oPartDoc.ReadOnly
Dim oBrowserPane As BrowserPane
For Each oBrowserPane In oPartDoc.BrowserPanes
If oBrowserPane.InternalName = "PmDefault" Then Exit For
Next
If Not oBrowserPane Is Nothing Then
Dim oTopNode As BrowserNode
Set oTopNode = oBrowserPane.TopNode
'SheetMetal parts have an additional node for folded model and flat pattern
Dim oStartNode As BrowserNode
If oPartDoc.DocumentSubType.DocumentSubTypeID = "{4D29B490-49B2-11D0-93C3-7E0706000000}" Then 'part
Set oStartNode = oTopNode
ElseIf oPartDoc.DocumentSubType.DocumentSubTypeID = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then 'sheetmetal part
Set oStartNode = oTopNode.BrowserNodes.Item(1)
Else
MsgBox ("Unknown PartDocumentType detected for file: " & vbCrLf & oPartDoc.FullDocumentName)
Exit Sub
End If
Dim i As Integer
Dim j As Integer
Dim oObjColl As ObjectCollection
Set oObjColl = ThisApplication.TransientObjects.CreateObjectCollection
For i = 1 To oStartNode.BrowserNodes.Count
On Error Resume Next
If isInternalNode(oStartNode.BrowserNodes.Item(i)) = False Then
''Debug.Print oStartNode.BrowserNodes.Item(i).NativeObject.Name
''Debug.Print oStartNode.BrowserNodes.Item(i).NativeObject.Type
Select Case oStartNode.BrowserNodes.Item(i).NativeObject.Type
Case kComponentOccurrenceObject:
Call oObjColl.Add(oStartNode.BrowserNodes.Item(i).NativeObject)
Case kCircularOccurrencePatternObject:
Dim oCPatternOccs As ObjectCollection
Set oCPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oCPatternOccs = GetPatternElements(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oCPatternOccs Is Nothing Then
For j = 1 To oCPatternOccs.Count
Call oObjColl.Add(oCPatternOccs.Item(j))
Next
End If
Case kRectangularOccurrencePatternObject:
Dim oRPatternOccs As ObjectCollection
Set oRPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oRPatternOccs = GetPatternElements(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oRPatternOccs Is Nothing Then
For j = 1 To oRPatternOccs.Count
Call oObjColl.Add(oRPatternOccs.Item(j))
Next
End If
Case kFeatureBasedOccurrencePatternObject:
Dim oFBPatternOccs As ObjectCollection
Set oFBPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oFBPatternOccs = GetPatternElements(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oFBPatternOccs Is Nothing Then
For j = 1 To oFBPatternOccs.Count
Call oObjColl.Add(oFBPatternOccs.Item(j))
Next
End If
Case kPlanarSketchObject:
Call oObjColl.Add(oStartNode.BrowserNodes.Item(i).NativeObject)
Case kDerivedPartComponentObject:
'ignore derived components
Case kDerivedAssemblyComponentObject:
'ignore derived components
'Case kBrowserNodeObject: 'By CheckCheck.Master
'?????
Case Else: 'Anything else should be an assemblyfeature *?*
Call oObjColl.Add(oStartNode.BrowserNodes.Item(i).NativeObject)
'Search for non-shared Sketches
Dim oSketch As PlanarSketch
Set oSketch = GetBaseSketch(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oSketch Is Nothing Then
Call oObjColl.Add(oSketch)
End If
Dim oSketch3D As Sketch3D
Set oSketch3D = GetBaseSketch3D(oStartNode.BrowserNodes.Item(i).BrowserNodes) 'By CheckCheck.Master
'Set oSketch3D = GetBaseSketch3D(oTopNode.BrowserNodes.Item(i).BrowserNodes)
If Not oSketch3D Is Nothing Then
Call oObjColl.Add(oSketch3D)
End If
Dim oBend As BendOptions
Set oBend = GetBend(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oBend Is Nothing Then
Call oObjColl.Add(oBend)
End If
Dim oCorner As CornerOptions
Set oCorner = GetCorner(oStartNode.BrowserNodes.Item(i).BrowserNodes)
If Not oCorner Is Nothing Then
Call oObjColl.Add(oCorner)
End If
End Select
End If
Next
'Setting temporary names
On Error Resume Next
For j = 1 To oObjColl.Count
oObjColl.Item(j).Name = "tmp_" & oObjColl.Item(j).Name
Next
Dim iExit As Integer
Dim sName As String
For i = 1 To oObjColl.Count
iExit = 1
Do
sName = StripTrailingNumbers(oObjColl.Item(i).Name)
If sName = "" Then Exit Do
sName = sName & iExit
oObjColl.Item(i).Name = sName
'Emergency Exit 999
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While oObjColl.Item(i).Name <> sName
Next
On Error GoTo 0
End If
End Sub
Private Sub ProcessAssBrowserPane(ByVal oAssDoc As AssemblyDocument)
'MsgBox oAssDoc.FullFileName
If oAssDoc.FullFileName Like "*Bieb HML*" Then Exit Sub
'Detect if Assembly/Part is Is Modifiable 'By CheckMaster
'MsgBox oPartDoc.IsModifiable
If oAssDoc.IsModifiable = False Then Exit Sub
'Did not work for Assembly
'Detect if Assembly/Part is Locked/Content Center 'By CheckMaster
'If oAssDoc.ComponentDefinition.IsContentMember = True Then Exit Sub
'MsgBox oAssDoc.ComponentDefinition.IsContentMember '' = False Then
'If the "ContentCenter" property set exists, the part came from Content Center
Dim IsCCPart As String
IsCCPart = oAssDoc.PropertySets.PropertySetExists("ContentCenter")
''MsgBox oAssDoc.DisplayName & "Assembly Is Content Center Part: " & IsCCPart
If IsCCPart = "True" Then Exit Sub
Dim oBrowserPane As BrowserPane
For Each oBrowserPane In oAssDoc.BrowserPanes
If oBrowserPane.InternalName = "AmBrowserArrangement" Then Exit For
Next
If Not oBrowserPane Is Nothing Then
Dim oTopNode As BrowserNode
Set oTopNode = oBrowserPane.TopNode
Dim i As Integer
Dim j As Integer
Dim oObjColl As ObjectCollection
Set oObjColl = ThisApplication.TransientObjects.CreateObjectCollection
Dim oSketchColl As ObjectCollection
Set oSketchColl = ThisApplication.TransientObjects.CreateObjectCollection
For i = 1 To oTopNode.BrowserNodes.Count
If isInternalNode(oTopNode.BrowserNodes.Item(i)) = False Then
On Error Resume Next
Select Case oTopNode.BrowserNodes.Item(i).NativeObject.Type
Case kComponentOccurrenceObject:
Call oObjColl.Add(oTopNode.BrowserNodes.Item(i).NativeObject)
Case kCircularOccurrencePatternObject:
Dim oCPatternOccs As ObjectCollection
Set oCPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oCPatternOccs = GetPatternElements(oTopNode.BrowserNodes.Item(i).BrowserNodes)
If Not oCPatternOccs Is Nothing Then
For j = 1 To oCPatternOccs.Count
Call oObjColl.Add(oCPatternOccs.Item(j))
Next
End If
Case kRectangularOccurrencePatternObject:
Dim oRPatternOccs As ObjectCollection
Set oRPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oRPatternOccs = GetPatternElements(oTopNode.BrowserNodes.Item(i).BrowserNodes)
If Not oRPatternOccs Is Nothing Then
For j = 1 To oRPatternOccs.Count
Call oObjColl.Add(oRPatternOccs.Item(j))
Next
End If
Case kFeatureBasedOccurrencePatternObject:
Dim oFBPatternOccs As ObjectCollection
Set oFBPatternOccs = ThisApplication.TransientObjects.CreateObjectCollection
Set oFBPatternOccs = GetPatternElements(oTopNode.BrowserNodes.Item(i).BrowserNodes)
If Not oFBPatternOccs Is Nothing Then
For j = 1 To oFBPatternOccs.Count
Call oObjColl.Add(oFBPatternOccs.Item(j))
Next
End If
Case kPlanarSketchObject:
Call oSketchColl.Add(oTopNode.BrowserNodes.Item(i).NativeObject)
Case Else: 'Anything else should be an assemblyfeature *?*
Call oObjColl.Add(oTopNode.BrowserNodes.Item(i).NativeObject)
'Search for non-shared Sketches
Dim oSketch As PlanarSketch
Set oSketch = GetBaseSketch(oTopNode.BrowserNodes.Item(i).BrowserNodes)
If Not oSketch Is Nothing Then
Call oSketchColl.Add(oSketch)
End If
End Select
End If
Next
'Setting temporary names
For j = 1 To oObjColl.Count
On Error Resume Next 'By CheckCheck.Master
oObjColl.Item(j).Name = "tmp_" & oObjColl.Item(j).Name
Next
Dim iExit As Integer
Dim sName As String
On Error Resume Next
For j = 1 To oObjColl.Count
iExit = 1
If InStr(oObjColl.Item(j).Name, ":") Then
Do
Err.Clear
oObjColl.Item(j).Name = Mid(Left(oObjColl.Item(j).Name, InStrRev(oObjColl.Item(j).Name, ":") - 1), 5) & ":" & iExit
'Emergency Exit 999
'Debug.Print iExit
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While Err.Number <> 0
Else
Do
sName = StripTrailingNumbers(oObjColl.Item(j).Name)
If sName = "" Then Exit Do
sName = sName & iExit
oObjColl.Item(j).Name = sName
'Notausstieg bei 999
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While oObjColl.Item(j).Name <> sName
End If
Next
'Sketches can all have the same name, no need to temp rename them
'Is this a bug in assembly sketches???
For j = 1 To oSketchColl.Count
sName = StripTrailingNumbers(oSketchColl.Item(j).Name)
If Not sName = "" Then
oSketchColl.Item(j).Name = sName & j
End If
Next
On Error GoTo 0
End If
End Sub
Private Function GetPatternElements(ByVal oNodes As BrowserNodesEnumerator) As ObjectCollection
Dim oElementsColl As ObjectCollection
Set oElementsColl = ThisApplication.TransientObjects.CreateObjectCollection
Dim oNode As BrowserNode
For Each oNode In oNodes
If Not oNode.NativeObject Is Nothing Then
If oNode.NativeObject.Type = kComponentOccurrenceObject Then
Call oElementsColl.Add(oNode.NativeObject)
Else
Dim oSubElementsColl As ObjectCollection
Set oSubElementsColl = ThisApplication.TransientObjects.CreateObjectCollection
Set oSubElementsColl = GetPatternElements(oNode.BrowserNodes)
If Not oSubElementsColl Is Nothing Then
Dim i As Integer
For i = 1 To oSubElementsColl.Count
Call oElementsColl.Add(oSubElementsColl.Item(i))
Next
End If
End If
End If
Next
Set GetPatternElements = oElementsColl
End Function
Private Function GetBaseSketch(ByVal oNodes As BrowserNodesEnumerator) As PlanarSketch
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
If oNode.NativeObject.Type = kPlanarSketchObject Then
Set GetBaseSketch = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Private Function GetBaseSketch3D(ByVal oNodes As BrowserNodesEnumerator) As Sketch3D
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
If oNode.NativeObject.Type = kSketch3DObject Then
Set GetBaseSketch3D = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Private Function GetBend(ByVal oNodes As BrowserNodesEnumerator) As BendOptions
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
MsgBox oNode.NativeObject.Name
If oNode.NativeObject.Type = kBendFeatureObject Then
Set GetBend = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Private Function GetCorner(ByVal oNodes As BrowserNodesEnumerator) As CornerOptions
Dim oNode As BrowserNode
For Each oNode In oNodes
On Error Resume Next 'By CheckCheck.Master
If Not oNode.NativeObject Is Nothing Then
If oNode.NativeObject.Type = kCornerOptionsObject Then
Set GetCorner = oNode.NativeObject
Exit For
End If
End If
Next
End Function
Private Sub RenumberSurfaceBodies(ByVal oNodes As BrowserNodesEnumerator)
On Error Resume Next
Dim i As Integer
For i = 1 To oNodes.Count
oNodes(i).NativeObject.Name = "tmp_" & oNodes(i).NativeObject.Name
Next
Dim sName As String
Dim iExit As Integer
For i = 1 To oNodes.Count
iExit = 1
Do
sName = StripTrailingNumbers(oNodes.Item(i).NativeObject.Name)
If sName = "" Then Exit Do
sName = sName & iExit
oNodes.Item(i).NativeObject.Name = sName
'Notausstieg bei 999
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While oNodes(i).NativeObject.Name <> sName
Next
On Error GoTo 0
End Sub
Private Sub RenumberWorkSurfaces(ByVal oNodes As BrowserNodesEnumerator)
On Error Resume Next
Dim i As Integer
For i = 1 To oNodes.Count
oNodes(i).NativeObject.Name = "tmp_" & oNodes(i).NativeObject.Name
Next
Dim sName As String
Dim iExit As Integer
For i = 1 To oNodes.Count
iExit = 1
Do
sName = StripTrailingNumbers(oNodes.Item(i).NativeObject.Name)
If sName = "" Then Exit Do
sName = sName & iExit
oNodes.Item(i).NativeObject.Name = sName
'Notausstieg bei 999
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While oNodes(i).NativeObject.Name <> sName
Next
On Error GoTo 0
End Sub
Private Sub RenumberConstraints(ByVal oNodes As BrowserNodesEnumerator)
Dim i As Integer
For i = 1 To oNodes.Count
oNodes(i).NativeObject.Name = "tmp_" & oNodes(i).NativeObject.Name
Next
For i = 1 To oNodes.Count
Dim iExit As Integer
iExit = 1
On Error Resume Next
Do
Err.Clear
oNodes.Item(i).NativeObject.Name = Mid(Left(oNodes.Item(i).NativeObject.Name, InStrRev(oNodes.Item(i).NativeObject.Name, ":") - 1), 5) & ":" & iExit
'Notausstieg bei 999
If iExit > 999 Then Exit Do
iExit = iExit + 1
Loop While Err.Number <> 0
Next
End Sub
Private Function StripTrailingNumbers(ByVal sName As String) As String
If Left(sName, 4) = "tmp_" Then
sName = Mid(sName, 5)
End If
Do While IsNumeric(Right(sName, 1)) = True
sName = Left(sName, Len(sName) - 1)
Loop
StripTrailingNumbers = sName
End Function
Private Function isInternalNode(ByVal oNode As BrowserNode) As Boolean
If oNode.Visible = False Then
isInternalNode = True
Exit Function
End If
Select Case True
Case oNode.BrowserNodeDefinition.Label = "Relationships":
isInternalNode = True
Call RenumberConstraints(oNode.BrowserNodes)
Case oNode.BrowserNodeDefinition.Label = "iMates": 'NativeObject=Part / AssemblyComponentDefinition
isInternalNode = True
Case oNode.BrowserNodeDefinition.Label = "Representations": '"Darstellungen":
isInternalNode = True
Case oNode.BrowserNodeDefinition.Label = "Origin": '"Ursprung":
isInternalNode = True
Case InStr(oNode.BrowserNodeDefinition.Label, "Positionsdarstellungen"):
isInternalNode = True
Case oNode.BrowserNodeDefinition.Label = "End of Features": '"Elementenende":
isInternalNode = True
Case oNode.BrowserNodeDefinition.Label = "Blocks": '"Blöcke": 'NativeObject=Nothing
isInternalNode = True
Case Left(oNode.BrowserNodeDefinition.Label, 12) = "Solid Bodies": '"SurfaceBodies": '"Volumenkörper(":
If oNode.NativeObject Is Nothing Then
Call RenumberSurfaceBodies(oNode.BrowserNodes)
isInternalNode = True
End If
Case Left(oNode.BrowserNodeDefinition.Label, 12) = "WorkSurfaces": '"Flächenkörper(":
If oNode.NativeObject Is Nothing Then
Call RenumberWorkSurfaces(oNode.BrowserNodes)
isInternalNode = True
End If
Case Left(oNode.BrowserNodeDefinition.Label, 10) = "DesignView": '"Ansicht:": 'NativeObject.type=kDesignViewRepresentationobject
If oNode.NativeObject.Type = ObjectTypeEnum.kDesignViewRepresentationObject Then
isInternalNode = True
End If
Case oNode.BrowserNodeDefinition.Label = "End of Part": '"Bauteilende": 'NativeObject.type=kendoffeaturesobject
isInternalNode = True
Case Else:
isInternalNode = False
End Select
End Function
Thanks Krieg for your support, 'GetBend' is working now, nice!
Disappointing that 'corner' cannot be made to work.
By means of a 'Watch' the value of the 'NativeObject' appears to be: <Application-defined or object-defined error>.
I can imagine something about your statement, regarding the 'API ObjectModel' it seems that we have the correct 'Corner', so it sounds plausible.
Is there a chance that 'Corner' is accessible through iLogic / VB.net?
Is that related to the 'DLLs' that are being accessed?
I don't think so, but is a 'Label' possibly suitable for a name change?
Greetings!
Can't find what you're looking for? Ask the community or share your knowledge.
Post to forums
![Autodesk Design & Make Report](https://forums.autodesk.com/t5/image/serverpage/image-id/1350519iCB55845EBFC43016/image-size/large?v=v2&px=999" "Autodesk Design & Make Report")