Sub Main() ' Get the active assembly. Dim oAsmDoc As AssemblyDocument oAsmDoc = ThisApplication.ActiveDocument ' Call the function that does the recursion. Call TraverseAssembly(oAsmDoc.ComponentDefinition.Occurrences, 1) 'set a message in the status bar ThisApplication.StatusBarText = "Finished" 'tell the user the files were created MessageBox.Show("Finish " , "iLogic") End Sub Private Sub TraverseAssembly(Occurrences As ComponentOccurrences, _ Level As Integer) ' Iterate through all of the occurrence in this collection. This ' represents the occurrences at the top level of an assembly. 'Declaration de variable Dim miroir As String = "_mir" Dim miroir2 as String = "_MIR" Dim miroir3 as String = "mir" Dim miroir4 as String = "MIR" Dim oOcc As ComponentOccurrence For Each oOcc In Occurrences Dim oOccName As String = oOcc.Name ' If the component is suppressed, skip the rest of the loop iteration If oOcc.Suppressed Then ' MessageBox.Show("La composante " & oOccName & " est inactive." & vbNewLine & "La programmation automatique va continuer" & vbNewLine & "en excluant la composante " & oOccName & ".") Continue For End If ' Print the name of the current occurrence. If oOcc.DefinitionDocumentType = kPartDocumentObject Then 'MessageBox.Show(oOcc.definition.Document.fullfilename) If oOcc.Definition.Type = 150995200 Then ' kSheetMetalComponentDefinitionObject 150995200 SheetMetal Component Definition Object. nom_complet = oOcc.definition.Document.file If oOcc.Name.Contains(miroir) Or oOcc.Name.Contains(miroir2) Or oOcc.Name.Contains(miroir3) Or oOcc.Name.Contains(miroir4) Then boucle(nom_complet) Else prog(nom_complet) End If End If End If ' Check to see if this occurrence represents a subassembly ' and recursively call this function to traverse through it. If oOcc.DefinitionDocumentType = kAssemblyDocumentObject Then Call TraverseAssembly(oOcc.SubOccurrences, Level + 1) End If Next End Sub Private Sub prog(nom_occ As File ) Dim customSet As PropertySet Dim custompersonSet As PropertySet Dim docpath As String docpath = ThisDoc.WorkspacePath() 'Declaration de ce document comme etant la variable utilis e doc_progs = nom_occ.AvailableDocuments doc_prog = doc_progs.item(1) docdefinition = doc_prog.componentdefinition If Not doc_prog.isModifiable Exit Sub End If nom = nom_occ.FullFileName On Error Resume Next customSet = doc_prog.PropertySets.Item("Design Tracking Properties") custompersonSet = doc_prog.PropertySets.Item("Inventor User Defined Properties") Projet = ThisApplication.DesignProjectManager.ActiveDesignProject.Name num_piece = customSet.Item("Part Number").Value materiel = customSet.Item("Material").Value epaisseur = CStr(Round(docdefinition.parameters.item("Epaisseur").Value / 2.54,4)) cut = custompersonSet.Item("T").Value If cut.contains("X") Or cut.contains("F") Then coupe = 1 Else coupe = 0 End If If Err.Number <> 0 Then 'MessageBox.Show("Il y a un probleme de variable dans la piece " & nom, "Erreur") If Dir(docpath & "\" & Projet,vbDirectory)="" Then MkDir (docpath & "\" & Projet) End If Dim InputString As String = nom My.Computer.FileSystem.WriteAllText _ (docpath & "\" & Projet & "\erreur.txt", InputString & vbNewLine, True) Exit Sub End If On Error Goto 0 On Error Resume Next Cintre = custompersonSet.Item("Cintre").Value If Cintre = "1" Then coupe = 0 End If On Error Goto 0 'Flat pattern export si necessaire If coupe = 1 Then 'Test pour voir si le dossier existe If Dir(docpath & "\" & Projet,vbDirectory)="" Then MkDir (docpath & "\" & Projet) End If 'Code pour exporter les donnees voulues en fichier texte fs = CreateObject("Scripting.FileSystemObject") qte = 1 'To Read If fs.FileExists(docpath & "\" & Projet & "\" & num_piece & ".txt") Then ts = fs.OpenTextFile(docpath & "\" & Projet & "\" & num_piece & ".txt") qte_lu = ts.ReadLine ts.Close qte = qte + Val(qte_lu) End If 'To write a = fs.CreateTextFile(docpath & "\" & Projet & "\" & num_piece & ".txt", True) Epaisseur_point = Replace(Epaisseur, ",", ".") a.WriteLine (qte & vbNewLine & materiel & vbNewLine & Epaisseur_point & vbNewLine & cut) a.Close 'Creation du fichier dwg If qte = 1 Then ' Get the DataIO object. Dim oDataIO As DataIO Dim z As Integer = 1 oDataIO = docdefinition.DataIO n_trous = docdefinition.Features.HoleFeatures.Count If n_trous <> 0 Then For z= 1 To n_trous docdefinition.Features.HoleFeatures.item(z).suppressed = True Next z End If ' Build the string that defines the format of the DXF file. Dim sOut As String 'sOut = "FLAT PATTERN DWG?AcadVersion=2013&Outerprofilelayer=0&Interiorprofileslayer=0&InvisibleLayers=IV_TANGENT;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_BEND;IV_BEND_DOWN;IV_FEATURE_PROFILES_DOWN&MergeProfilesIntoPolyline=TRUE&SimplifySplines=TRUE&REBASEGEOMETRY=TRUE" sOut = "FLAT PATTERN DWG?AcadVersion=2004&Outerprofilelayer=0&Interiorprofileslayer=0&BendLayer=6&BendDownLayer=6&InvisibleLayers=IV_TANGENT;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_BEND;IV_BEND_DOWN;IV_FEATURE_PROFILES_DOWN&MergeProfilesIntoPolyline=TRUE&SimplifySplines=TRUE&REBASEGEOMETRY=TRUE" '&BendLayer=SCRIBE&BendDownLayer=SCRIBE 'Test pour voir si le dossier existe If Dir(docpath & "\" & Projet,vbDirectory)="" Then MkDir (docpath & "\" & Projet) End If ' Create the DXF file. oDataIO.WriteDataToFile (sOut, docpath & "\" & Projet & "\" & num_piece & ".dwg") If n_trous <> 0 Then For z= 1 To n_trous docdefinition.Features.HoleFeatures.item(z).suppressed = False Next z End If End If Else 'On Error Resume Next 'Kill (docpath & "\" & Projet & "\" & num_piece & ".*") 'On Error Goto 0 'do nothing End If End Sub Private Sub boucle(occ_mir As file) Projet = ThisApplication.DesignProjectManager.ActiveDesignProject.Name Dim oRefFile As File Dim DrgDoc As PartDocument invDoc = occ_mir.AvailableDocuments.item(1) DrgDoc = invDoc For Each oRefFile In DrgDoc.file.ReferencedFiles 'Dim oOrigRefName As ComponentOccurrence oOrigRefName = oRefFile.AvailableDocuments roger = oOrigRefName.item(1) nom_complet = roger.file If roger.fullfilename.Contains("MIR") Or roger.fullfilename.Contains("mir") Then boucle(nom_complet) Else prog(nom_complet) End If Next End Sub