Das VBA-Makro  korrigiert nach zB 'Component Replace' widersprüchliche Instanzennamen aller Kindern des ausgewählten Produktes,

nicht jedoch die Enkel, Neffen, Cousinen und sonstige Verwandtschaft.

 

Der Code:


'---------------------------------------------------------------------------------------
' Module    : modInstEqNameOneLevel
' Author    : jherzog
' Date      : 16.04.2016
' Purpose   : Rename/sync instances of all child products in the next level
'           : while sorting the instances within a product
'---------------------------------------------------------------------------------------
Option Explicit

Sub CatMain()
   Dim oRootProds As Products
   Dim oSel As Selection
   Dim oPP

   CATIA.Interactive = False                               'no interaction allowed

   Set oSel = CATIA.ActiveDocument.Selection
   If oSel.Count2 = 0 Then                                 'anything selected?
      MsgBox "No product selected!" & vbCrLf _
           & "You need to select a product" & vbCrLf _
           & "before reading the list!", _
             vbOKOnly Or vbCritical, "ReadList"
      Exit Sub
   Else
      Set oPP = oSel.Item2(1)

      Select Case oPP.Type
         Case "Product"
            'check if part or product
            If TypeName(oPP.Value.ReferenceProduct.Parent) = "ProductDocument" Then
               CATIA.StatusBar = oPP.Value.Name & ": Renaming instances ..."

               oPP.Value.ApplyWorkMode DEFAULT_MODE        'set work mode to expose P/N

               Set oRootProds = oPP.Value.ReferenceProduct.Products
               CATIA.StatusBar = oPP.Value.Name & ": Renaming instances ... First pass ..."
               InstanceEqualName oRootProds, True          'first pass to clear low numbers

               CATIA.StatusBar = oPP.Value.Name & ": Renaming instances ... Second pass ..."
               InstanceEqualName oRootProds, False         'second pass to sort instances

               CATIA.StatusBar = oPP.Value.Name & ": Renaming instances ... Done."

            Else                                           'part instance selected
               MsgBox "No product selected!" & vbCrLf _
                    & "You need to select a product" & vbCrLf _
                    & "before reading the list!", _
                      vbOKOnly Or vbCritical, "ReadList"
               oSel.Clear
               Exit Sub

            End If
         Case Else                                         'selection was not a product
            MsgBox "No product selected!" & vbCrLf _
                 & "You need to select a product" & vbCrLf _
                 & "before reading the list!", _
                   vbOKOnly Or vbCritical, "ReadList"
            oSel.Clear
            Exit Sub
      End Select
   End If

   CATIA.Interactive = True                                'allow interaction

End Sub

'---------------------------------------------------------------------------------------
' Procedure : InstanceEqualName
' Author    : jherzog
' Date      : 19.04.2016
' Time      : 20:00
' Languages : VBA 6.5
' V5-Release: V5R19/21
' Purpose   : Rename product instances to match part name,
'           : while sorting the instances within a product
' Parms     : oProducts: Node of products, eg. 'CATIA.ActiveDocument.Product.Products'
'           : bFirstPass: indicates if first or second pass
' Ret. Value: -
'
' Syntax    : InstanceEqualName oMainProducts, True
'
' Prereqs   : an opened product
' Remarks   :
'---------------------------------------------------------------------------------------
'
Sub InstanceEqualName(oProducts As Products, bFirstPass As Boolean)

   Dim strPNum As String
   Dim strPName As String
   Dim iPos As Integer
   Dim n As Integer
   Dim oinstance As Product


   On Error GoTo InstanceEqualName_Error

   For n = 1 To oProducts.Count

      Set oinstance = oProducts.Item(n)                    'get a product/part
      strPNum = oinstance.PartNumber                       'get part number
'      strPName = oinstance.Name                            'this is the name to change

      If bFirstPass = True Then
         iPos = oProducts.Count + 1                        'first pass clear 'count' positions
      Else
         iPos = 1                                          'second pass assign instances
      End If

      'this causes an error if the instance already exists
      oinstance.Name = strPNum & "." & iPos                'rename instance
      DoEvents
   Next

   Exit Sub
   '---------------------------------------------------------------------------------------
InstanceEqualName_Error:
   Dim errMsg As String
   Dim errRet As VbMsgBoxResult

   Select Case Err.Number
      Case -2147467259                                     'couldn't rename instance
         iPos = iPos + 1                                   'increase instance counter
         Resume                                            'try again
      Case Else
         errMsg = Err.Number & ": " & Err.Description & " in procedure InstanceEqualName"
         errRet = MsgBox(errMsg, vbOKOnly, "InstanceEqualName")
   End Select

   'Resume Next                                             'fall thru to quit sub
   '---------------------------------------------------------------------------------------
End Sub

Zum Seitenanfang