Macro export cartouche dans Excel

Bonjour,

je souhaiterais réaliser une macro qui :
1- Ouvre les CatDrawing présent dans un dossier
2- Récupère les données du cartouche et les envoie dans Excel pour tous les plans ouvert.

J'ai des cartouches identique pour chaque plans et les différentes valeurs à récupérées sont contenues dans une textbox nommée suivant sa description.
Il faudrait donc que j'arrive à copier la valeur à l’intérieur de la textbox et passer à la suivante puis passer au plan suivant etc...

J'ai commencé à écrire un code mais je bloque sur la récupération de la valeur du Textbox. (et aussi sur l'ouverture de tous les fichiers CatDraw, l'insertion d'une fonction permettant de rentrer l'adresse du dossier voulu dans le UserForm... mais chaque chose en son temps)

Voici le code créé pour l'instant :

Code:

'**********************************************************************
' Macro d'export des valeurs d'un cartouche dans un fichier Excel
' Permet l'ouverture de tous les plans CATDraw d'un dossier et d'en extraire
' les paramètres du cartouche afin de controler rapidement sous excel que
' tout est bien rempli sans ouvrir manuellement tous les plans

' Fonction recherche du dossier non encore écrite


'Public myProduct As Product
'Public myDocument As Document
Public myDrawing As DrawingDocument
Public myExcel As Object
Public myWorksheet As Worksheet
Public line As Integer 'n° de ligne du tableau Excel

Sub CATMain()

'********************************
' recherche ou déclare l'application Excel

    On Error Resume Next
    Set myExcel = GetObject(, "Excel.Application")
If Err <> o Then
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Visible = True
End If
On Error GoTo 0

    UserForm2.Show

End Sub

'---------------------------------------------------
'   ExportPropCartouche est une fonction qui doit aller chercher certaines Textboxes du cartouche
'   et copier les valeurs dans la cellule Excel correspondante.

Sub ExportPropCartouche()



Set myDrawing = CATIA.ActiveDocument

'On Error Resume Next
myWorksheet.Range("A" & line).Value = myDrawing.Item("TOOL_NO_DRN_NAME").Value
'myWorksheet.Range("B" & line).Value =
'myWorksheet.Range("C" & line).Value = "TOOL NO OPP"
'myWorksheet.Range("D" & line).Value = "TITLE"
'myWorksheet.Range("E" & line).Value = "TOOL TITLE"
'myWorksheet.Range("F" & line).Value = "ISSUE"
'myWorksheet.Range("G" & line).Value = "SIZE"
'myWorksheet.Range("H" & line).Value = "NO of Sheet"
'myWorksheet.Range("I" & line).Value = "Sheet"
'myWorksheet.Range("J" & line).Value = "Drawn Date"
'myWorksheet.Range("K" & line).Value = "Drawn Name"
'myWorksheet.Range("L" & line).Value = "Checked Date"
'myWorksheet.Range("M" & line).Value = "Checked Name"
'myWorksheet.Range("N" & line).Value = "Approved Date"
'myWorksheet.Range("O" & line).Value = "Approved Name"
'myWorksheet.Range("P" & line).Value = "TOOL WEIGHT"
'myWorksheet.Range("Q" & line).Value = "PLANT"
'myWorksheet.Range("R" & line).Value = "PROGRAM"
line = 2

End Sub

Ainsi que le UserForm :

Code:

Private Sub CommandButtonEnd_Click()
    UserForm1.Hide
    End
End Sub

Private Sub CommandButtonExport_Click()
'*************************
'Création du classeur Excel et de la ligne des entêtes
Set myWorkbook = myExcel.workbooks.Add
Set myWorksheet = myExcel.Sheets.Add
'myWorksheet.Name = myProduct.PartNumber '"Export"
myWorksheet.Range("A1").Value = "DRAWING NAME"
myWorksheet.Range("B1").Value = "TOOL NO DRN"
myWorksheet.Range("C1").Value = "TOOL NO OPP"
myWorksheet.Range("D1").Value = "TITLE"
myWorksheet.Range("E1").Value = "TOOL TITLE"
myWorksheet.Range("F1").Value = "ISSUE"
myWorksheet.Range("G1").Value = "SIZE"
myWorksheet.Range("H1").Value = "NO of Sheet"
myWorksheet.Range("I1").Value = "Sheet"
myWorksheet.Range("J1").Value = "Drawn Date"
myWorksheet.Range("K1").Value = "Drawn Name"
myWorksheet.Range("L1").Value = "Checked Date"
myWorksheet.Range("M1").Value = "Checked Name"
myWorksheet.Range("N1").Value = "Approved Date"
myWorksheet.Range("O1").Value = "Approved Name"
myWorksheet.Range("P1").Value = "TOOL WEIGHT"
'myWorksheet.Range("Q1").Value = "PLANT"
'myWorksheet.Range("R1").Value = "PROGRAM"
line = 2

Call ExportPropCartouche

Voici également à quoi ressemble le cartouche
https://we.tl/pHhQVucliD
Quelqu'un aurait une idée pour m'aider ?

Merci d'avance pour votre aide.

Cordialement

Bonjour Charly,

Tu es devenu accros à l'export de données CATIA vers Excel...

Ci dessous un code qui va te permettre de sélectionner un dossier et ouvrir tous les CATDrawing qui s'y trouve.

Code:

Sub catmain()

Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionner le répertoire source", ssfTous)
    If objFolder Is Nothing Then Exit Sub
    Set oFolderItem = objFolder.Items.Item
    mySourceFolder = oFolderItem.Path
    mySourceFolder = mySourceFolder & "\"
    Set objShell = Nothing
    Set objFolder = Nothing
    Set oFolderItem = Nothing
    File = Dir(mySourceFolder & "*.CATDrawing")
    Do While Len(File)
        Dim documents1 As Documents
        Set documents1 = CATIA.Documents
        Set document1 = documents1.Open(mySourceFolder & File)
        Set MonDessin = CATIA.ActiveDocument
        MonDessin.Activate
        'appeler la fonction d'export
        File = Dir
    Loop

End Sub

Pour l'export, si j'ai bien compris ton cartouche, le texte est renseigné dans le calque de détail?
Il faudra alors activer ce calque et rechercher les textes en fonction leur nom.
Est ce que les textes que tu veux exporter ont tous une racine commune (dans leur noms par exemple "*_NAME") qui permettrait de les sélectionner?

Merci pour ce morceau de code je vais l'intégrer de suite.
Pour le cartouche effectivement, nous avons un calque de "travail" avec les vues des pièces (nommé "WORKSHEET") et un calque "cartouche et suivi d'indice" (nommé "TITLE BLOCK").
Pour le nom, dans la théorie, oui nous devrions avoir des racines commune "_NAME", "_DATE" ou "_VALUE" mais il arrive des fois ou cela n'est plus le cas suite à une erreur d'un designer dans le renommage. Dans l'idéal il faudrait récupérer tous les textes si possible. Sinon au moins les valeurs racines ci-dessous :


Merci pour l'aide encore une fois

Bonjour Charly,

Ci dessous le code pour exporter les DrwTxt du cartouche.
Je n'ai pas utilisé de UserForm, tout est dans le module principal.

Le nom des DrwTxt à exporter est renseigné dans une table "TextToExport(17, 1)".
Les DrwTxt doivent se trouver dans un calque nommé "TITLE BLOCK", si ce calque n'est pas trouvé on l'indique dans le tableau Excel à coté du nom du CATDrawing.
Si un DrwTxt n'est pas trouvé, sa cellule est remplie en rouge.

Code:

'**********************************************************************
' Macro d'export des valeurs d'un cartouche dans un fichier Excel
' Permet l'ouverture de tous les plans CATDraw d'un dossier et d'en extraire
' les paramètres du cartouche afin de controler rapidement sous excel que
' tout est bien rempli sans ouvrir manuellement tous les plans
' Fonction recherche du dossier non encore écrite
' http://catiav5.forumactif.org/t1612-macro-export-cartouche-dans-excel#7136

Public myDrawing As DrawingDocument
Public myExcel As Object
Public myWorksheet As Worksheet
Public line As Integer 'n° de ligne du tableau Excel
Public TextToExport(17, 1) 'table de 18x2 des noms de DrwTxt à exporter
Sub CATMain()

'********************************
' recherche ou déclare l'application Excel

On Error Resume Next
Set myExcel = GetObject(, "Excel.Application")
If Err <> o Then
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Visible = False
End If
On Error GoTo 0

'********************************
' Initialisation de la table des textes à exporter
'colonne 0 nom de l'entete Excel
'colonne 1 nom du DrwText dans le cartouche
TextToExport(0, 0) = "DRAWING NAME"
TextToExport(0, 1) = ""
TextToExport(1, 0) = "TOOL NO DRN"
TextToExport(1, 1) = "TOOL_NO_DRN_NAME"
TextToExport(2, 0) = "TOOL NO OPP"
TextToExport(2, 1) = "TOOL_NO_DRN_NAME"
TextToExport(3, 0) = "TITLE"
TextToExport(3, 1) = "TITLE_NAME"
TextToExport(4, 0) = "TOOL TIPE"
TextToExport(4, 1) = "TOOL_TYPE_NAME"
TextToExport(5, 0) = "ISSUE"
TextToExport(5, 1) = "ISSUE"
TextToExport(6, 0) = "SIZE"
TextToExport(6, 1) = "SIZE_VALUE"
TextToExport(7, 0) = "NO of Sheet"
TextToExport(7, 1) = "NO_SHEETS_VALUE"
TextToExport(8, 0) = "Sheet"
TextToExport(8, 1) = "SHEET_VALUE"
TextToExport(9, 0) = "Drawn Date"
TextToExport(9, 1) = "DRAWN_DATE"
TextToExport(10, 0) = "Drawn Name"
TextToExport(10, 1) = "DRAWN_NAME"
TextToExport(11, 0) = "Checked Date"
TextToExport(11, 1) = "CHECKED_DATE"
TextToExport(12, 0) = "Checked Name"
TextToExport(12, 1) = "CHECKED_NAME"
TextToExport(13, 0) = "Approved Date"
TextToExport(13, 1) = "APPROVED_DATE"
TextToExport(14, 0) = "Approved Name"
TextToExport(14, 1) = "APPROVED_NAME"
TextToExport(15, 0) = "TOOL WEIGHT"
TextToExport(15, 1) = "TOOL_WEIGHT_VALUE"
TextToExport(16, 0) = "PLANT"
TextToExport(16, 1) = "PLANT_NAME"
TextToExport(17, 0) = "PROGRAM"
TextToExport(17, 1) = "PROGRAM_NAME"

'***********************************
' créer le classeur Excel et l'entete
Dim myWorkbook As Workbook
Set myWorkbook = myExcel.Workbooks.Add
myWorkbook.Activate
Set myWorksheet = myWorkbook.Worksheets.Add
myWorksheet.Activate

For i = 0 To 17
    myWorksheet.Cells(1, i + 1).Value = TextToExport(i, 0)
Next
line = 2

'Demande de sélectionner le dossier source:
Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionner le répertoire source", ssfTous)
If objFolder Is Nothing Then Exit Sub
Set oFolderItem = objFolder.Items.Item
mySourceFolder = oFolderItem.Path
myWorksheet.Name = oFolderItem
mySourceFolder = mySourceFolder & "\"
Set objShell = Nothing
Set objFolder = Nothing
Set oFolderItem = Nothing
File = Dir(mySourceFolder & "*.CATDrawing")

'Boucle sur tous les CATDrawing du dossier
On Error Resume Next
Do While Len(File)
    Dim documents1 As Documents
    Set documents1 = CATIA.Documents
    Set document1 = documents1.Open(mySourceFolder & File)
    Set myDrawing = CATIA.ActiveDocument
    myDrawing.Activate
    myWorksheet.Cells(line, 1).Value = myDrawing.Name
    Set mySheet = myDrawing.Sheets.Item("TITLE BLOCK") 'le calque de détail doit toujours s'appeler TITLE BLOCK
    If Err.Number = 0 Then 'le calque TITLE BLOCK a été trouvé
        Set mySelection = myDrawing.Selection
        mySelection.Clear
        mySelection.Add mySheet
        
        For i = 1 To 17
            mySelection.Search "CATDrwSearch.DrwText.Name= " & TextToExport(i, 1)
            If mySelection.Count > 0 Then
                Set mytext = mySelection.Item(1).Value
                myWorksheet.Cells(line, i + 1).Value = mytext.Text
            Else
                myWorksheet.Cells(line, i + 1).Interior.ColorIndex = 3 ' rouge si le DrwTxt est manquant
            End If
        Next
        mySelection.Clear
    Else    'le calque TITLE BLOCK n'a pas été trouvé
        myWorksheet.Cells(line, 2).Value = "Pas de calque TITLE BLOCK"
        Err.Clear
    End If
    line = line + 1
    File = Dir
Loop
MsgBox "Export terminé"
myExcel.Visible = True

End Sub

Je n'avais pas encore testé mais merci beaucoup Marc, ça fonctionne à merveille.