Macro Import d'un arbre catia à partir d'un fichier excel

Bonjour à tous,

Je sollicite votre aide pour cette macro, l'idée serait de créer à partir d'un fichier excel, les noms des products, parts et ensuite de les importer dans catia, ils seront vide mais si j'arrive déja à avoir un arbre organisé et avec les noms ce serait top.
J'ai réussi à importer des propriétés d'excel vers catia, je pense que c'est réalisable
merci pour votre aide

Bonjour,

Ci dessous un code en CATScript que j'ai trouvé mais pas testé, je te laisse essayer:
Tiens nous au courant du résultat.

Code:


'*************************************************************************

'*****  Excel Product Structure Import

'*****  Author:  Nick Pisca

'*****  Support:  nicholas.pisca@gehrytechnologies.com & nickpisca@gmail.com

'*****  Date:  March 7, 2008, April 1, 2008

'*****  Description:

'*****

'*****  Status:  In-Prog. and Working

'*****  Advancements:  CATParts, April 1;

'*****  Requirements:  Excel to be open.

'*****  Compatibility:

'*****  Designed In:  DP V1R2 or newer

'*************************************************************************

 

'*****  Declarations

 

Dim AvailDocs As Documents

Dim MySel As Selection

Dim TheSPAWorkbench

Dim MyHSFactory As HybridShapeFactory

Dim MyHybridBodies As HybridBodies

Dim Zaxis As HybridShapeDirection

Dim MyXL

Dim XLSheets

Dim XLActSheet

Dim CurCells

Dim TotalRows As Integer

Dim FS 'As FileSystem

 

 

 

Sub CATMain()

'AUserForm1.Show

'CATStart

End Sub

 

Sub CATStart()

Track

 

If IsAppOpen("Excel") = False Then

  MsgBox "This script requires DP and Excel to be open simultaneously.  Open your Excel file with the corresponding tree.", vbInformation, "Open Programs."

Exit Sub

End If

 

Set FS = CATIA.FileSystem

Set AvailDocs = CATIA.Documents

Set MyXL = GetObject(, "Excel.Application")

Set XLSheets = MyXL.Sheets

Set XLActSheet = XLSheets.Item(1)        'XLSheets.Count)                            'MyXL.ActiveSheet

Set CurCells = XLActSheet.Cells

   

TotalRows = ReturnTotalRows - 2

 

CheckFolders

 

'            CurCells(XLCounter, 15) = Ccoords(2)

 

If CurCells(1, 1).Value = "" Or CurCells(1, 10).Value = "" Then

  MsgBox "Excel Structure may be incorrect.  Use Column J for your Paths.", vbCritical, "Missing Cells."

Exit Sub

End If

 

Dim MainDoc As Document

Set MainDoc = AvailDocs.Add("Product")

MainDoc.Product.PartNumber = CurCells(1, 1).Value

MainDoc.SaveAs (CurCells(1, 10).Value & "\" & CurCells(1, 1).Value & ".CATProduct")

 

 

'SendKeys "Check", True

'SendKeys "{Enter}", True

 

 

RecCell 1, 1, MainDoc.Product

'MainDoc.Product

 

End Sub

 

Function RecCell(RowNum As Variant, ColNum As Variant, ParentProduct As Variant) As Variant

Dim CurProducts As Products

Set CurProducts = ParentProduct.Products

 

Dim Kill As Integer

Kill = SpacesBelow(CInt(RowNum + 1), ColNum)

If Kill = 0 Then

Exit Function

Else

For nn = RowNum To Kill + RowNum

   

    Dim NewProd As Product

    If CurCells(nn + 1, ColNum + 1).Value <> "" Then

        If CurCells(nn + 1, 10).Value = "" Then

            Set NewProd = CurProducts.AddNewProduct(CurCells(nn + 1, ColNum + 1).Value)

        ElseIf CurCells(nn + 1, ColNum + 1).Font.Bold = True Then

            Set NewProd = CurProducts.AddNewComponent("Part", CurCells(nn + 1, ColNum + 1).Value)

              SuppressSaveMessage NewProd, (CurCells(nn + 1, 10).Value & "\" & CurCells(nn + 1, ColNum + 1).Value & ".CATPart")

        Else

            Set NewProd = CurProducts.AddNewComponent("Product", CurCells(nn + 1, ColNum + 1).Value)

              SuppressSaveMessage NewProd, (CurCells(nn + 1, 10).Value & "\" & CurCells(nn + 1, ColNum + 1).Value & ".CATProduct")

        End If

          RecCell nn + 1, ColNum + 1, NewProd

    End If

Next 'nn

End If

 

 

End Function

 

 

Sub CheckFolders()

For X = 1 To TotalRows

Dim curFolderStr As String

  curFolderStr = CurCells(X, 10).Value

If FS.FolderExists(curFolderStr) = False Then

    If curFolderStr <> "" Then

        If FolderVerify(curFolderStr) Then

              FS.CreateFolder (curFolderStr)

        Else

              harr = Split(curFolderStr, "\")

            Dim HName As String

              HName = harr(0)

            For X2 = 1 To UBound(harr)

                  HName = HName & "\" & harr(X2)

                If FS.FolderExists(HName) = False Then

                      FS.CreateFolder HName

                End If

            Next 'X2

        End If

    End If

End If

Next 'X

End Sub

 

Function FolderVerify(curFolderStr As String) As Boolean

'On Error GoTo blast

HHH = FS.CreateFolder(curFolderStr)

FolderVerify = True

Exit Function

blast:

FolderVerify = False

End Function

 

 

Sub SuppressSaveMessage(NewProd2 As Variant, MainPath As String)

'On Error GoTo BL

NewProd2.ReferenceProduct.Parent.SaveAs MainPath

Exit Sub

BL:

End Sub

 

 

 

Public Sub Pause(NbSec As Single)

Dim Finish As Single

Finish = Timer + NbSec

DoEvents

Do Until Timer >= Finish

Loop

End Sub

 

Function SpacesBelow(RowNum As Variant, ColNum As Variant) As Integer

Dim RC As Integer

RC = 0

Dim CurName As String

CurName = CurCells(RowNum, ColNum)

While CurName = "" And RowNum + RC <= TotalRows + 1

  CurName = CStr(CurCells(RowNum + RC, ColNum).Value)

  RC = RC + 1

Wend

SpacesBelow = RC - 1

End Function

 

Function ReturnTotalRows() As Integer

Dim RowCounter As Integer

RowCounter = 1

Dim FileCheck As Boolean

FileCheck = False

While RowCounter < 1000 And FileCheck = False

  FileCheck = True

For colcounter = 1 To 15

    If CurCells(RowCounter, colcounter) <> "" Then

          FileCheck = False

    End If

Next 'colcounter

  RowCounter = RowCounter + 1

Wend

ReturnTotalRows = RowCounter

End Function

 

Function IsAppOpen(AppName As String) As Boolean

'On Error GoTo blast

Set MyApp = GetObject(, AppName & ".Application")

IsAppOpen = True

Exit Function

blast:

IsAppOpen = False

End Function

 

Sub Track()

  ScriptName = "ExcelProductStructure_V0R2"

  URL = "http://www.gehrytechnologies.com/scripttracking.php"

'    On Error GoTo OHNOERROR

  UserName = Environ("UserName")

  computerName = Environ("COMPUTERNAME")

  UserDomain = Environ("USERDOMAIN")

  OS = Environ("OS")

  Dat = Date

  Tim = Time

  data = "q=" & ScriptName & "____" & UserName & "____" & computerName & "____" & UserDomain & "____" & Dat & "____" & Tim

If InStr(OS, "Windows") > 0 Then

    Dim http

    Set http = CreateObject("MSXML2.XMLHTTP")

      http.Open "POST", URL, False

      http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

      http.Send data

End If

OHNOERROR:

  Err.Clear

End Sub




Hello merci pour ta réponse.
J'ai tester ce matin, la macro plante au moment ou il doit télécharger un script, ci-dessous:
dommage
Sub Track()

 ScriptName = "ExcelProductStructure_V0R2"

 URL = ".gehrytechnologies.com/scripttracking.php"

'    On Error GoTo OHNOERROR

 UserName = Environ("UserName")

 computerName = Environ("COMPUTERNAME")

 UserDomain = Environ("USERDOMAIN")

 OS = Environ("OS")

 Dat = Date

 Tim = Time

 data = "q=" & ScriptName & "____" & UserName & "____" & computerName & "____" & UserDomain & "____" & Dat & "____" & Tim

If InStr(OS, "Windows") > 0 Then

   Dim http

   Set http = CreateObject("MSXML2.XMLHTTP")

     http.Open "POST", URL, False

     http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

     http.Send data

End If

OHNOERROR:

 Err.Clear

End Sub

Salut,


J'ai simplifié la macro, elle va créer un Catproduct (défini en ligne 2 du fichier Excel) puis un certain nombre de CATPart  (à partir de la ligne 3).
Tu peux y renseigner les différentes propriétés pour les documents Catia:


Voici le Code en VBA:

Code:

'*************************************************************************
'*****  Excel Product Structure Import
'*****  Author: Marc L.
'*****  Date:  30/04/2021
'*****  https://catiav5.forumactif.org/t1711-macro-import-d-un-arbre-catia-a-partir-d-un-fichier-excel#7406
'*************************************************************************
' il faut un fichier Excel composé comme suit:
'PartNumber |   Révision    |   Définition  |   Nomenclature    |   Description
'Produit-0  |   OR          |   Ensemble    |   0               |   test0
'Part-1     |   OR          |   Bati        |   1               |   test1
'Part-2     |   OR          |   Support     |   2               |   test2

'*****  Declarations
Dim AvailDocs As Documents
Dim MyXL
Dim XLSheets
Dim XLActSheet
Dim CurCells
Dim TotalRows As Integer

Sub CATMain()

If IsAppOpen("Excel") = False Then
    MsgBox "Veuillez ouvrir un fichier Excel comprenant les données à importer.", vbInformation, "Open Programs."
    Exit Sub
End If

Set AvailDocs = CATIA.Documents
Set MyXL = GetObject(, "Excel.Application")
Set XLSheets = MyXL.Sheets
Set XLActSheet = XLSheets.Item(1)
Set CurCells = XLActSheet.Cells

TotalRows = ReturnTotalRows - 2
 
'Création du produit de tête:
Dim MainDoc As Document
Set MainDoc = AvailDocs.Add("Product")
MainDoc.Product.PartNumber = CurCells(2, 1).Value
MainDoc.Product.Revision = CurCells(2, 2).Value
MainDoc.Product.Definition = CurCells(2, 3).Value
MainDoc.Product.Nomenclature = CurCells(2, 4).Value
MainDoc.Product.DescriptionRef = CurCells(2, 5).Value

'Création des part
For Line = 3 To TotalRows
    Dim NewProd As Product
    Dim myPartName As String
    myPartNumber = CurCells(Line, 1).Value
    'Set oProduct = oProducts.AddNewComponent("CATPart", "" & i)
    Set NewProd = MainDoc.Product.Products.AddNewComponent("CATPart", myPartNumber)
    NewProd.Revision = CurCells(Line, 2).Value
    NewProd.Definition = CurCells(Line, 3).Value
    NewProd.Nomenclature = CurCells(Line, 4).Value
    NewProd.DescriptionRef = CurCells(Line, 5).Value
Next
End Sub

Function ReturnTotalRows() As Integer

Dim RowCounter As Integer
RowCounter = 1
Dim FileCheck As Boolean
FileCheck = False
While RowCounter < 1000 And FileCheck = False
    FileCheck = True
    For colcounter = 1 To 15
        If CurCells(RowCounter, colcounter) <> "" Then
              FileCheck = False
        End If
    Next 'colcounter
    RowCounter = RowCounter + 1
Wend
ReturnTotalRows = RowCounter
End Function

Function IsAppOpen(AppName As String) As Boolean

On Error GoTo blast
Set MyApp = GetObject(, AppName & ".Application")
IsAppOpen = True
Exit Function

blast:
IsAppOpen = False
End Function

Merci beaucoup je vais test

hello ça marche nickel merci pour ton aide