Code:
'----------------------------------------------------------------------------------
' Author:
' Marcus Mangelsdorf
'
' Purpose:
' Show information about the occurence of update errors and their location
'
' Usage:
' Run macro after updating a part/product to get a MsgBox with the encountered
' feature update errors
'
' History:
' Version Date Comment
' 1.0 2012-11-21 Initial release
'
' Notes:
' The result can personalized by setting the variables listed in the setup
' section below (beginning below the variable definition)
'----------------------------------------------------------------------------------
Option ExplicitSub CATMain()
'Object variables
Dim objSel As Selection
Dim objFaulty As Object
'String variables
Dim strType As String 'Document type
Dim strSearchTerm As String
Dim strTopNode As String
Dim strAllErrors As String
'Number variables
Dim i As Long
Dim lngMaxLevel As Long
'-------------- SETUP --------------
'Set boundaries for tree elements that are included in the output
strTopNode = "" 'Beginning of the name of the topmost geometry set (eg. "#C" will stop at "#Conceptual Design")
lngMaxLevel = 16 'Maximum number of parents to include in the output (eg. level 2 will stop at grandparent)
'------------ END SETUP ------------
'Initialize output string
strAllErrors = "Folgende Geometrieelemente konnten nicht aufgebaut werden:" & vbCrLf & vbCrLf
'Initialize selection object
Set objSel = CATIA.ActiveDocument.Selection
objSel.Clear
'Search for all errors in geometric features
strSearchTerm = "CATGmoSearch.GeometricFeature.Error=TRUE"
objSel.Search strSearchTerm
'Loop through all items of the selection object
For i = 1 To objSel.Count2
'Update output string
strAllErrors = strAllErrors & RecurseParent(objFaulty, strTopNode, lngMaxLevel) & vbCrLf & vbCrLf
Next i
strAllErrors = strAllErrors & "Es sind insgesamt " & objSel.Count2 & " Fehler aufgetreten."
MsgBox strAllErrors, vbInformation, "Aufbaufehler gefunden"
End Sub 'End CATMain
'------------------------------------------------------------------------------
' Name:
' RecurseParent (private function)
'
' Purpose:
' Generate a string containing a graphical representation of the ancestors
' of the given child object up to the given maximum level or until the
' beginning of the parent's name resembles the given stop string.
'
' Assumptions:
' A CATIA Document is active and the passed object has at least a name
' property. To make sense, it should also have a parent property.
'
' Parameters:
' In
' strLastParent by value : name of upmost parent to search for
' lngMaxLevel by value : max number of ancestors to include
' Out
' None
' In/Out
' objChild by reference : downmost tree object
' lngLevel : counting variable to track the level of the
' recursion and control the spacing
'
' Returns:
' A string containing the "family" of the given object
'------------------------------------------------------------------------------
Private Function RecurseParent( _
ByRef objChild As Object, _
Optional ByVal strLastParent As String = "", _
Optional ByVal lngMaxLevel As Long = 16, _
Optional ByRef lngLevel As Long = 0) _
As String
Dim objParent As Object
Dim lngCurrentLevel As Long
'Check if strLastParent parameter was given, if not set it to the name of the file
If Len(strLastParent) = 0 Then strLastParent = CATIA.ActiveDocument.Name
'Check if last parent is reached or parent is already the filename or maximum level is reached
'If so, return child's name
If Left(objChild.Name, Len(strLastParent)) = strLastParent _
Or objChild.Name = CATIA.ActiveDocument.Name _
Or lngLevel >= lngMaxLevel Then
RecurseParent = objChild.Name
Exit Function
End If
'Check if parent exists - if not, return "No parent"
On Error Resume Next 'Deactivate automatic error handling
Set objParent = objChild.Parent 'Try to get parent
If Err.Number <> 0 Then
RecurseParent = "No parent"
Exit Function
End If
Err.Clear
On Error GoTo 0 'Reactivate automatic error handling
'Save current level and increase total level to pass it on
lngCurrentLevel = lngLevel
lngLevel = lngLevel + 1
'Return recursive function call and child's name
RecurseParent = RecurseParent(objParent, strLastParent, lngMaxLevel, lngLevel) & vbCrLf _
& Space((lngLevel - lngCurrentLevel - 1) * 3) & "'-- " & objChild.Name
End Function 'End RecurseParent
Foren auf CAD.de (alle Foren)
| 
Notepad++ sei Dank konnte ich die Liste aber schon wesentlich lesbarer gestalten und die Duplikate entfernen. (In der Makrorekorderaufnahme kommen alle Elemente doppelt vor - klar, ist ja auch nicht lang genug, der String 
schöne Rekursion) den Pfad bis zum fehlerhaften Element ausgeben lassen.
