Macro VBA - Enregistrer sous de tous les CATProduct et CATPart uniquement présents dans CATIA.ActiveDocument ?

Bonjour,

Je cherche à créer une macro ayant pour but d’effectuer une action "d'enregistrement sous" sur des CATProduct et des CATPart contenus uniquement dans le document actif en cours de travail, en général un sous ensemble ouvert a partir d'un assemblage général lui même encore ouvert dans une autre fenêtre CATIA.
Cette action se déclenche s'il y a une différence entre le FileName et le PartNumber.

J'arrive à créer une macro (voir ci-dessous) qui parcourt tous les CATProduct et CATPart ouverts dans CATIA mais pas à la limiter a parcourir uniquement les documents présents dans la fenêtre active.

Auriez vous une idée pour arriver a ce but ?

Macro parcourant tous les éléments ouverts dans CATIA (fenêtres actives et non actives):

Code:

Option Explicit
Sub Enregistrer_sous()

Dim DocumentActif As Document
Set DocumentActif = catia.ActiveDocument
'-----------------Selection arbre CATIA------------------------
Dim sSel As Selection
Set sSel = catia.ActiveDocument.Selection
sSel.Clear
sSel.Search "CATAsmSearch.Product,all"
'-----------------Boucle dans l'arbre CATIA--------------------
Dim i As Integer
For i = 1 To sSel.Application.Documents.Count
    Dim doctest As Document
    Set doctest = sSel.Application.Documents.Item(i)
    ' Parcourir les documents sélectionnés dans CATIA
      
        Dim nomreference As String
        Dim fileName As String
        
        
        
        
            ' Vérifier si le document est une CATPart ou une CATProduct
            Select Case TypeName(doctest)
            
            Case Is = "PartDocument"
                nomreference = doctest.Product.partNumber & ".CATPart"
                ' Vérifier si les noms sont différents
                If nomreference <> doctest.Name Then
                    ' Construire le nom de fichier en utilisant le numéro de référence
                    fileName = doctest.Product.partNumber & ".CATPart"
                    
                    ' Enregistrer le document sous le nouveau nom de fichier
                    doctest.SaveAs "Chemin d'accès à modifier" & fileName
                    On Error Resume Next
                    On Error GoTo 0
                End If
                
            Case Is = "ProductDocument"
                nomreference = doctest.Product.partNumber & ".CATProduct"
                ' Vérifier si les noms sont différents
                If nomreference <> doctest.Name Then
                    ' Construire le nom de fichier en utilisant le numéro de référence
                    fileName = doctest.Product.partNumber & ".CATProduct"
                    
                    ' Enregistrer le document sous le nouveau nom de fichier
                    doctest.SaveAs "Chemin d'accès à modifier" & fileName
                    On Error Resume Next
                    On Error GoTo 0
                End If
            End Select
        
        
Next i
    
MsgBox ("Enregistrement terminé, veuillez sauvegarder à  nouveau le Product de tête pour conserver les liens")

End Sub

Salut John,

Avec for i = 1 To sSel.Application.Documents.Count tu créer une boucle sur tous les documents en session.

Je te propose une autre méthodes qui scanne le produit actif et inscrit le nom du fichier et le PArtnumber dans un tableau. Tu pourra ensuite faire ta sauvegarde.

Code:


'Macro qui liste les CATPart Et CATProduct du document ACTIF UNIQUEMENT
'https://catiav5.forumactif.org/t1804-macro-vba-enregistrer-sous-de-tous-les-catproduct-et-catpart-uniquement-presents-dans-catia-activedocument#7693
'Marc Litzler 04-2023
'*************************************************
'définition de nouveaux types de variable
Type TabReference
fieldFullname As String
fieldPN As String
End Type
'définition des variables publiques
Public TabBOM() As TabReference ' tableau des documents à controler contenant le PartNumber et le nomcomplet du fichier


'FONCTION PRINCIPALE

Sub CATMain()
    Call ListeBom 'fonction de création de la liste des documents à controler
End Sub

Sub ListeBom()
'Get the current CATIA assembly
Dim oProdDoc As ProductDocument
Set oProdDoc = CATIA.ActiveDocument

Dim oRootProd As Product
Set oRootProd = oProdDoc.Product

ReDim TabBOM(0) ' redimensionner
TabBOM(0).fieldFullname = oRootProd.ReferenceProduct.Parent.FullName
                '.FullName --> Nom complet du fichier avec extesion et le chemin d'enregistrement
                '.Name --> Nom complet du fichier avec extesion

TabBOM(0).fieldPN = oRootProd.PartNumber
'Begin scroll down the specification tree
Call WalkDownTree(oRootProd)

'*****************************************************************
'  Trier le tableau, si nécessaire
'*****************************************************************
   
Dim temp0 As String
Dim temp1 As String
For i = 1 To UBound(TabBOM)
    For j = i To UBound(TabBOM)
        If TabBOM(i).fieldPN > TabBOM(j).fieldPN Then
            temp0 = TabBOM(j).fieldFullname
            temp1 = TabBOM(j).fieldPN
           
            TabBOM(j).fieldFullname = TabBOM(i).fieldFullname
            TabBOM(j).fieldPN = TabBOM(i).fieldPN
            TabBOM(i).fieldFullname = temp0
            TabBOM(i).fieldPN = temp1
           
        End If
    Next j
    Debug.Print TabBOM(i).fieldPN
Next i
Debug.Print i
End Sub

'---------------------------------------------------------------------
' WalkDownTree is a recursive function to scroll down the spec tree and output names of each item
'---Script by Emmett Ross
'---www.scripting4v5.com
'---Revised July 21, 2012
'---This macro will walk down the tree and display the part number for every component and if it is a part or product
'--------------------------------------------------------------------------
Sub WalkDownTree(oInProduct As Product)

Dim oInstances As Products
Set oInstances = oInProduct.Products
On Error Resume Next

'Récupère le nom de la référence du parent:
monParent = oInProduct.Parent.Parent.ReferenceProduct.Parent.Product.PartNumber
'Récupère le nom de fichier du parent (pour recherche composant):
monRefProductName = oInProduct.ReferenceProduct.Parent.Product.Name
'monRefProductName = oInProduct.ReferenceProduct.Parent.Name
Err.Clear

' --------------------------------------------------------
' *** Recherche des liens cassés      V00.1            ***
' --------------------------------------------------------
If Err.Number <> 0 Then
  ReDim Preserve TabBOM(UBound(TabBOM) + 1)
  TabBOM(UBound(TabBOM)).fieldFullname = "lien casse"
  TabBOM(UBound(TabBOM)).fieldPN = oInProduct.Name
  Err.Clear
  Exit Sub
End If

'-----No instances found then this is CATPart
   
If oInstances.Count = 0 Then
        If isInTabBOM(oInProduct.PartNumber) = False Then 'unicité du PartNumber
            ReDim Preserve TabBOM(UBound(TabBOM) + 1)
            TabBOM(UBound(TabBOM)).fieldFullname = oInProduct.ReferenceProduct.Parent.FullName 'oInProduct.ReferenceProduct.Parent.Path pour le chemin seul
            TabBOM(UBound(TabBOM)).fieldPN = oInProduct.PartNumber
        End If
    Exit Sub
Else 'c'est un produit ou un composant
'Si c'est un composant ou le produit de tête, on ne l'inscrit pas dans le tableau
    If monParent <> monRefProductName And Not monParent = Empty Then
        If isInTabBOM(oInProduct.PartNumber) = False Then 'unicité du PartNumber
            ReDim Preserve TabBOM(UBound(TabBOM) + 1)
            TabBOM(UBound(TabBOM)).fieldFullname = oInProduct.ReferenceProduct.Parent.FullName 'oInProduct.ReferenceProduct.Parent.Path pour le chemin seul
            TabBOM(UBound(TabBOM)).fieldPN = oInProduct.PartNumber
        End If
    End If
        Dim k As Integer
        For k = 1 To oInstances.Count
            Dim oInst As Product
            Set oInst = oInstances.Item(k)
            Call WalkDownTree(oInst)
        Next
End If
End Sub

'*****************************************************************
'Fonction qui verifie si la valeur a déjà été exportée
'*****************************************************************
Function isInTabBOM(valueToCheck)
    isInTabBOM = False
    For l = 1 To UBound(TabBOM)
        If TabBOM(l).fieldPN = valueToCheck Then 'unicité du PartNumber
            isInTabBOM = True
        End If
    Next
End Function


Salut,

Ci joint le code complet avec l'enregistrement des fichiers.

Code:


'*************************************************
'Macro qui Sauvegarde les CATPart Et CATProduct du document ACTIF UNIQUEMENT
'en les renommant avec le PARTNumber
'https://catiav5.forumactif.org/t1804-macro-vba-enregistrer-sous-de-tous-les-catproduct-et-catpart-uniquement-presents-dans-catia-activedocument#7693
'Marc Litzler 04-2023
'*************************************************

'définition de nouveaux types de variable
Type TabReference
fieldName As String
fieldPN As String
End Type
'définition des variables publiques
Public TabBOM() As TabReference ' tableau des documents à traiter contenant le PartNumber et le nom du fichier


'FONCTION PRINCIPALE

Sub CATMain()

    'Définition du dossier de sauvegarde
    Dim myNewPath As String
    myNewPath = "C:\Temp\"
    'myNewPath = CATIA.ActiveDocument.Path & "\"  ' récupère le dossier du document actif
   
    Call ListeBom 'appel de la fonction de création de la liste des documents
   
    CATIA.DisplayFileAlerts = False ' permet de ne pas afficher la boite de dialogue à chaque enregistrement.
    Dim myDocs As Documents
    Set myDocs = CATIA.Documents
   
    ' Parcourir les documents contenus dans le document actif
    For i = 0 To UBound(TabBOM)

        Dim doctest  As Document
        Set doctest = myDocs.Item(TabBOM(i).fieldName)

        Dim nomreference As String
        Dim fileName As String
       
        ' Vérifier si le document est une CATPart ou une CATProduct
        Select Case TypeName(doctest)
       
        Case Is = "PartDocument"
            nomreference = doctest.Product.PartNumber & ".CATPart"
            ' Vérifier si les noms sont différents
            If nomreference <> doctest.Name Then
                ' Construire le nom de fichier en utilisant le numéro de référence
                fileName = TabBOM(i).fieldPN & ".CATPart"
               
                ' Enregistrer le document sous le nouveau nom de fichier
                doctest.SaveAs myNewPath & fileName
            End If
           
        Case Is = "ProductDocument"
            nomreference = doctest.Product.PartNumber & ".CATProduct"
            ' Vérifier si les noms sont différents
            If nomreference <> doctest.Name Then
                ' Construire le nom de fichier en utilisant le numéro de référence
                fileName = TabBOM(i).fieldPN & ".CATProduct"
               
                ' Enregistrer le document sous le nouveau nom de fichier
                doctest.SaveAs myNewPath & fileName
            End If
        End Select
    '**************************
    Next i
    'ré-enregistre le produit de tête pour conserver les liens
    CATIA.ActiveDocument.Save
    CATIA.DisplayFileAlerts = True
   
    MsgBox "Enregistrement terminé", vbInformation, "SAUVEGARDE"

End Sub

Sub ListeBom()
'Get the current CATIA assembly
Dim oProdDoc As ProductDocument
Set oProdDoc = CATIA.ActiveDocument

Dim oRootProd As Product
Set oRootProd = oProdDoc.Product
   
ReDim TabBOM(0) ' redimensionner
TabBOM(0).fieldName = oRootProd.ReferenceProduct.Parent.Name
                '.FullName --> Nom complet du fichier avec extension et le chemin d'enregistrement
                '.Name --> Nom complet du fichier avec extension

TabBOM(0).fieldPN = oRootProd.PartNumber
'Begin scroll down the specification tree
Call WalkDownTree(oRootProd)

'*****************************************************************
'  Trier le tableau, si nécessaire
'*****************************************************************
   
Dim temp0 As String
Dim temp1 As String
For i = 1 To UBound(TabBOM)
    For j = i To UBound(TabBOM)
        If TabBOM(i).fieldPN > TabBOM(j).fieldPN Then
            temp0 = TabBOM(j).fieldName
            temp1 = TabBOM(j).fieldPN
           
            TabBOM(j).fieldName = TabBOM(i).fieldName
            TabBOM(j).fieldPN = TabBOM(i).fieldPN
            TabBOM(i).fieldName = temp0
            TabBOM(i).fieldPN = temp1
           
        End If
    Next j
    Debug.Print TabBOM(i).fieldPN
Next i
Debug.Print i
End Sub

'---------------------------------------------------------------------
' WalkDownTree is a recursive function to scroll down the spec tree and output names of each item
'---Script by Emmett Ross
'---www.scripting4v5.com
'---Revised July 21, 2012
'---This macro will walk down the tree and display the part number for every component and if it is a part or product
'--------------------------------------------------------------------------
Sub WalkDownTree(oInProduct As Product)

Dim oInstances As Products
Set oInstances = oInProduct.Products
On Error Resume Next

'Récupère le nom de la référence du parent:
monParent = oInProduct.Parent.Parent.ReferenceProduct.Parent.Product.PartNumber
'Récupère le nom de fichier du parent (pour recherche composant):
monRefProductName = oInProduct.ReferenceProduct.Parent.Product.Name
'monRefProductName = oInProduct.ReferenceProduct.Parent.Name
Err.Clear

' --------------------------------------------------------
' *** Recherche des liens cassés      V00.1            ***
' --------------------------------------------------------
If Err.Number <> 0 Then
  ReDim Preserve TabBOM(UBound(TabBOM) + 1)
  TabBOM(UBound(TabBOM)).fieldName = "lien casse"
  TabBOM(UBound(TabBOM)).fieldPN = oInProduct.Name
  Err.Clear
  Exit Sub
End If

'-----No instances found then this is CATPart
   
If oInstances.Count = 0 Then
        If isInTabBOM(oInProduct.PartNumber) = False Then 'unicité du PartNumber
            ReDim Preserve TabBOM(UBound(TabBOM) + 1)
            TabBOM(UBound(TabBOM)).fieldName = oInProduct.ReferenceProduct.Parent.Name
            TabBOM(UBound(TabBOM)).fieldPN = oInProduct.PartNumber
        End If
    Exit Sub
Else 'c'est un produit ou un composant
'Si c'est un composant ou le produit de tête, on ne l'inscrit pas dans le tableau
    If monParent <> monRefProductName And Not monParent = Empty Then
        If isInTabBOM(oInProduct.PartNumber) = False Then 'unicité du PartNumber
            ReDim Preserve TabBOM(UBound(TabBOM) + 1)
            TabBOM(UBound(TabBOM)).fieldName = oInProduct.ReferenceProduct.Parent.Name
            TabBOM(UBound(TabBOM)).fieldPN = oInProduct.PartNumber
        End If
    End If
        Dim k As Integer
        For k = 1 To oInstances.Count
            Dim oInst As Product
            Set oInst = oInstances.Item(k)
            Call WalkDownTree(oInst)
        Next
End If
End Sub

'*****************************************************************
'Fonction qui verifie si la valeur a déjà été exportée
'*****************************************************************
Function isInTabBOM(valueToCheck)
    isInTabBOM = False
    For l = 1 To UBound(TabBOM)
        If TabBOM(l).fieldPN = valueToCheck Then 'unicité du PartNumber
            isInTabBOM = True
        End If
    Next
End Function


Attention:
-aux liens, les autres CATProduct en session qui utilisent les mêmes fichiers vont pointés sur ces nouveaux fichiers.
-CATIA n'autorise pas certains caractères spéciaux pour les noms de fichier, s'il sont présent dans un PARTNumber, la macro va planter.