REPOS_ERICCA/magicsld/Commun.vb

Module Commun

    Public Const Pi As Double = 3.1415926535897931
    Public Epsilon As Double = 0.000000001 'à changer en fonction du type d'unité utilisé

    Public Imax As Double = 1 ' valeur maximale de l'inertie.
    Public Amax As Double = 1000 ' et de l'aire

    Public NBAreteDoublon As Integer  ' sais pas où d'autre ne peut mémoriser ce nombre...

    Public swApp As SldWorks.SldWorks
    Public swPart As SldWorks.PartDoc
    Public swModel As SldWorks.ModelDoc2

    Public lst_AreteVolume As New Collections.ObjectModel.Collection(Of SlyAreteVol) ' liste de courbes appartenant au volume
    Public lst_AreteCoque As New Collections.ObjectModel.Collection(Of SlyAreteCoque) ' liste de courbes appartenant aux coques
    Public lst_AretePoutre As New Collections.ObjectModel.Collection(Of SlyAretePoutre) ' liste de courbe libres
    Public lst_FaceVolume As New Collections.ObjectModel.Collection(Of SlyFaceVolume)    ' liste de faces appartenant au volume
    Public lst_FaceCoque As New Collections.ObjectModel.Collection(Of SlyFaceCoque) ' liste de face libres
    Public lst_SommetVolume As New Collections.ObjectModel.Collection(Of SlySommetVolume)
    Public lst_SommetCoque As New Collections.ObjectModel.Collection(Of SlySommetCoque)
    Public lst_sommetPoutre As New Collections.ObjectModel.Collection(Of SlySommetPoutre)

    'Public lst_MiniPoutre As New Collection
    Public lst_AreteDoublon As New Collection

    'Public Structure AretesDoublon
    '    Dim AreteVol As EncapArete
    '    Dim AreteCoque As EncapArete
    'End Structure


    Public Structure sectionPoutre
        Dim nom As String
        Dim I1 As Double
        Dim I2 As Double
        Dim D1 As Double
        Dim D2 As Double
        Dim D3 As Double
        Dim D4 As Double
        Dim D5 As Double
        Dim D6 As Double
        Dim Aire As Double
    End Structure


    Public Enum tipe_e
        Volume = 0
        coque = 1
        poutre = 2
        MiniPoutre = 3
    End Enum


    'Public Sub Preparer_pour_Magic()
    '    ' routine qui (en en appelant d'autres) génère les SlyClasses finales (avec les conditions aux limites
    '    ' mais elle n'enregistre pas les infos dans les propriétés des entités.

    '    Dim TypeAnno As Long
    '    Dim Anno As SldWorks.Annotation
    '    Dim Note As SldWorks.Note
    '    Dim swEnt As SldWorks.Entity
    '    Dim vAttEntArr As Object
    '    Dim reponse As Integer
    '    Dim textAnno As String
    '    Dim lst_cal As New Collection
    '    Dim i As Integer
    '    Dim e As Integer


    '    Call Commun.GenererListes()
    'puisque l'on relit les annotations, il faut effacer les anciennes, 
    'Dim s1 As SlyAreteVol
    'For Each s1 In lst_AreteVolume
    '    s1.ResetCL()
    'Next
    'Dim s2 As SlyAreteCoque
    'For Each s2 In lst_AreteCoque
    '    s2.ResetCL()
    'Next
    'Dim s3 As SlyAretePoutre
    'For Each s3 In lst_AretePoutre
    '    s3.ResetCL()
    'Next
    'Dim s4 As SlyFaceVol
    'For Each s4 In lst_FaceVolume
    '    s4.ResetCL()
    'Next
    'Dim s5 As SlyFaceCoque
    'For Each s5 In lst_FaceCoque
    '    s5.ResetCL()
    'Next
    'Dim s6 As SlySommetVolume
    'For Each s6 In lst_SommetVolume
    '    s6.ResetCL()
    'Next
    'Dim s7 As SlySommetCoque
    'For Each s7 In lst_SommetCoque
    '    s7.ResetCL()
    'Next
    'Dim s8 As SlySommetPoutre
    'For Each s8 In lst_sommetPoutre
    '    s8.ResetCL()
    'Next

    'Anno = swModel.GetFirstAnnotation2

    'Do While Not Anno Is Nothing
    '    TypeAnno = Anno.GetType
    '    If TypeAnno = 6 Then

    '        Note = Anno.IGetSpecificAnnotation
    '        vAttEntArr = Anno.GetAttachedEntities2

    '        For e = 0 To UBound(vAttEntArr)

    '            swEnt = vAttEntArr(e)      ' 0 si on a juste une entité.

    '            textAnno = Note.GetText
    '            Select Case Mid(textAnno, 1, 3)
    '                Case "Fx,", "Fy,", "Fz,", "Mx,", "My,", "Mz,", "Px,", "Py,", "Pz,", "Pn,", "Al,", "Au,", "Ar,", "Ux,", "Uy,", "Uz,", "Rx,", "Ry,", "Rz,", "Da,", "Dx,", "Dy,", "Dz,"
    '                    'MsgBox "On a une bonne entité"

    '                    Dim cl As New CaL
    '                    'cl.swEnt = swEnt
    '                    'cl.TypeCL = Mid(Note.GetText, 1, 2)
    '                    For i = 4 To Len(textAnno) ' changer les virgules en point pour le val
    '                        If Mid(textAnno, i, 1) = "," Then Mid(textAnno, i, 1) = "."
    '                    Next i
    '                    'cl.valeur = Val(Right(textAnno, Len(textAnno) - 3))

    '                    Dim enti As Object
    '                    enti = trouver(swEnt)
    '                    enti.addCaL(Mid(textAnno, 1, 2), Val(Right(textAnno, Len(textAnno) - 3)))
    '                Case Else
    '                    reponse = MsgBox(" Une annotation a un texte qui n'est pas reconnu, " & Chr(13) & " si " & Note.GetText & Chr(13) & "doit être une condition limite alors il doit être modifié.", 65, "Condition aux limite non reconnue")
    '                    If reponse = 3 Then Exit Sub
    '            End Select
    '        Next e

    '    End If

    '    Anno = Anno.GetNext3
    'Loop


    ' maintenant on met des attributs sur les entités en fonction des conditions aux limites...

    'For Each s1 In lst_AreteVolume
    '    s1.MettreAttributPourConditionLimite()
    'Next

    'For Each s2 In lst_AreteCoque
    '    s2.MettreAttributPourConditionLimite()
    'Next

    'For Each s3 In lst_AretePoutre
    '    s3.MettreAttributPourConditionLimite()
    'Next

    'For Each s4 In lst_FaceVolume
    '    s4.MettreAttributPourConditionLimite()
    'Next

    'For Each s5 In lst_FaceCoque
    '    s5.MettreAttributPourConditionLimite()
    'Next

    'For Each s6 In lst_SommetVolume
    '    s6.MettreAttributPourConditionLimite()
    'Next

    'For Each s7 In lst_SommetCoque
    '    s7.MettreAttributPourConditionLimite()
    'Next

    'For Each s8 In lst_sommetPoutre
    '    s8.MettreAttributPourConditionLimite()
    'Next


    ' End Sub

    Public Sub GenererListes(Optional ByVal ChercheAttribut As Boolean = True)
        ' sub qui créé les entités Sly... et le met dans les listes

        Dim vBodies As Object
        Dim swBody As SldWorks.Body2
        Dim v As Integer
        Dim swFace As SldWorks.Face2
        Dim swLoop As SldWorks.Loop2
        Dim swCoArete As SldWorks.CoEdge
        Dim swArete As SldWorks.Edge
        Dim swSommet1 As SldWorks.Vertex
        Dim swSommet2 As SldWorks.Vertex
        'Dim nouveau As Boolean ' bit qui dit si on est entrain d'updater (false) ou si on recommence du début (true)

        ' on doit commencer par vider les listes, sinon on peut travailler sur les listes d'un autre fichier...
        ' ne vérifie plus si on update ou si on recommence, ce n'est plus nécessaire.
        Intersections.RegisterAttribut()

        videliste()
        Call SuperFace.reinitialiser() ' remet les compteurs à 0
        Call SuperArete.reinitialiser()
        Call SuperSommet.reinitialiser()

        vBodies = swPart.GetBodies2(SwConst.swBodyType_e.swSolidBody, True)
        If Not vBodies Is Nothing Then
            For v = 0 To UBound(vBodies)
                swBody = vBodies(v)
                swFace = swBody.GetFirstFace

                Do While Not swFace Is Nothing
                    If trouver(swFace, tipe_e.Volume) Is Nothing Then
                        Dim slyface As New SlyFaceVolume(swFace)
                        lst_FaceVolume.Add(slyface)
                    End If


                    swLoop = swFace.GetFirstLoop
                    Do While Not swLoop Is Nothing

                        swCoArete = swLoop.GetFirstCoEdge
                        Dim coa As Integer
                        For coa = 0 To swLoop.GetEdgeCount - 1

                            swArete = swCoArete.GetEdge
                            If (Not Ignorer(swArete)) Then
                                If trouver(swArete, tipe_e.Volume, True) Is Nothing Then
                                    Dim slyArete As New SlyAreteVol(swArete)
                                    lst_AreteVolume.Add(slyArete)
                                End If

                                swSommet1 = swArete.GetStartVertex
                                If IsNothing(swSommet1) Then
                                    'MsgBox("On a une courbe sans sommet")
                                Else
                                    If (trouver(swSommet1, tipe_e.Volume) Is Nothing) Then
                                        Dim slySommet As New SlySommetVolume(swSommet1)
                                        lst_SommetVolume.Add(slySommet)
                                    End If

                                    swSommet2 = swArete.GetEndVertex
                                    If (trouver(swSommet2, tipe_e.Volume) Is Nothing) Then
                                        Dim slySommet As New SlySommetVolume(swSommet2)
                                        lst_SommetVolume.Add(slySommet)
                                    End If
                                End If

                                swCoArete = swCoArete.GetNext
                            End If
                        Next coa ' fin de loop sur les coaretes

                        swLoop = swLoop.GetNext
                    Loop ' fin loop sur loop

                    swFace = swFace.GetNextFace()
                Loop ' fin loop sur faces
            Next v ' next volume
        End If  ' s'il y a un corps (ou plus) on entre dans la boucle, sinon on continue sur les coques et poutres


        ' on fait le tour des features pour avoir les poutres et les coques
        Dim feat As SldWorks.Feature
        Dim vSupprime As Object
        Dim bSupprime As Boolean
        Dim ent As SldWorks.Entity
        Dim attr As SldWorks.Attribute


        feat = swPart.FirstFeature

        Do While Not feat Is Nothing

            vSupprime = feat.IsSuppressed
            bSupprime = CBool(vSupprime)
            If Not bSupprime Then  ' on vérifie que l'entité est pas supprimée

                Select Case feat.GetTypeName
                    Case "CompositeCurve", "3DSplineCurve", "Helix"  'le feature est une courbe libre

                        Dim refCourbe As SldWorks.ReferenceCurve

                        refCourbe = feat.GetSpecificFeature2
                        swArete = refCourbe.GetFirstSegment
                        Do While Not swArete Is Nothing

                            If (Not Ignorer(swArete)) Then
                                Dim slyArete As SlyAretePoutre
                                slyArete = trouver(swArete, tipe_e.poutre)

                                If slyArete Is Nothing Then
                                    slyArete = New SlyAretePoutre(swArete)
                                    lst_AretePoutre.Add(slyArete)
                                End If

                                swSommet1 = swArete.GetStartVertex
                                If IsNothing(swSommet1) Then
                                    'MsgBox("On a une courbe sans sommet")
                                Else
                                    If trouver(swSommet1, tipe_e.poutre) Is Nothing Then
                                        Dim slySommet As New SlySommetPoutre(swSommet1)
                                        lst_sommetPoutre.Add(slySommet)
                                    End If

                                    swSommet2 = swArete.GetEndVertex
                                    If trouver(swSommet2, tipe_e.poutre) Is Nothing Then
                                        Dim slySommet As New SlySommetPoutre(swSommet2)
                                        lst_sommetPoutre.Add(slySommet)
                                    End If
                                End If

                                ' on cherche s'il n'y aurait pas un attribut sur la poutre
                                'If ChercheAttribut Then
                                Try
                                    ent = swArete
                                    attr = ent.FindAttribute(Intersections.DefAttrRCP1, 0)
                                    slyArete.swAttribute = attr
                                    If Left(attr.GetName, 4) = "Mini" Then swArete.Display(2, 1, 0, 1, True) Else swArete.Display(2, 0, 1, 0, True)
                                    'Dim xyz() As Double
                                    'xyz = slyarete.GetPoint3
                                    'slyarete.X3 = xyz(0)
                                    'slyarete.y3 = xyz(1)
                                    'slyarete.z3 = xyz(2)
                                Catch ex As Exception
                                    MsgBox("Une poutre sans attributs est détectée dans le modèle!")
                                End Try

                            End If

                            swArete = Nothing
                            swArete = refCourbe.GetNextSegment

                        Loop


                    Case "PLine", "ExtruRefSurface", "RevolvRefSurf", " SweepRefSurface", "BlendRefSurface", "OffsetRefSurface", "ExtendRefSurface", "PlanarSurface", "RadiateRefSurface", "MidRefSurface", "FillRefSurface"
                        ' le feature est une surface libre, certains types de surface n'ont pas été gardés car
                        ' leur face appartient à un autre feature ou parce qu'il sont impossible à retrouver dans un multimodèle


                        ' Attention, si c'est une PLine ça peut prendre un volume

                        Dim body As SldWorks.Body2
                        Dim vFaces As Object
                        Dim vf As Object
                        Dim slyFace As SlyFaceCoque

                        vFaces = feat.GetFaces
                        If Not vFaces Is Nothing Then
                            For Each vf In vFaces
                                swFace = vf
                                body = swFace.GetBody


                                If Not (body.GetType = SwConst.swBodyType_e.swSolidBody) Then  ' si le body est quelquechose de solide alors on a le feature Pline d'un solide....

                                    slyFace = trouver(swFace, tipe_e.coque)
                                    If slyFace Is Nothing Then

                                        slyFace = New SlyFaceCoque(swFace)
                                        lst_FaceCoque.Add(slyFace)
                                    End If


                                    ' ***** détection des attributs des coques
                                    attr = Nothing
                                    If ChercheAttribut Then
                                        Try
                                            ent = swFace
                                            attr = ent.FindAttribute(Intersections.DefAttrRCCoque, 0)
                                            slyFace.swAttribute = attr
                                        Catch ex As Exception
                                            MsgBox("Une coque sans attributs est détectée dans le modèle!")
                                        End Try

                                        If IsNothing(attr) Then  ' on a trouvé un attribut de coque
                                            'il n'y a pas encore d'attributs sur cette coque.
                                            'MsgBox("Le putain d'attribut n'a pas été détecté!")
                                        End If
                                    End If

                                    swLoop = swFace.GetFirstLoop
                                    Do While Not swLoop Is Nothing
                                        swCoArete = swLoop.GetFirstCoEdge
                                        Dim coa As Integer
                                        For coa = 0 To swLoop.GetEdgeCount - 1

                                            swArete = swCoArete.GetEdge

                                            If (Not Ignorer(swArete)) Then
                                                If trouver(swArete, tipe_e.coque) Is Nothing Then
                                                    Dim slyArete As New SlyAreteCoque(swArete)
                                                    lst_AreteCoque.Add(slyArete)
                                                End If

                                                swSommet1 = swArete.GetStartVertex
                                                If IsNothing(swSommet1) Then
                                                    'MsgBox("On a une courbe sans sommet")
                                                Else
                                                    If trouver(swSommet1, tipe_e.coque) Is Nothing Then
                                                        Dim slySommet As New SlySommetCoque(swSommet1)
                                                        lst_SommetCoque.Add(slySommet)
                                                    End If

                                                    swSommet2 = swArete.GetEndVertex
                                                    If trouver(swSommet2, tipe_e.coque) Is Nothing Then
                                                        Dim slySommet As New SlySommetCoque(swSommet2)
                                                        lst_SommetCoque.Add(slySommet)
                                                    End If
                                                End If

                                                swCoArete = swCoArete.GetNext
                                            End If
                                        Next coa ' fin de loop sur les coaretes

                                        swLoop = swLoop.GetNext
                                    Loop ' fin loop sur loop
                                Else
                                    'MsgBox("On vient de retirer une PLine appartenant à un volume!", MsgBoxStyle.Exclamation)
                                End If
                            Next vf
                        End If

                    Case Else ' n'est pas un feature intéressant...
                        ' rien
                End Select
            End If ' fin du if sur la suppression du feature
            feat = feat.GetNextFeature
        Loop

    End Sub

    Public Sub MettreNoms()
        ' place les noms des SlyClasses sur les entités puis sauvegarde

        'Debug.Write("  Title        = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoTitle))
        'Debug.Write("  Subject      = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoSubject))
        'Debug.Write("  Author       = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoAuthor))
        'Debug.Write("  Keywords     = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoKeywords))
        'Debug.Write("  Comment      = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoComment))
        'Debug.Write("  SavedBy      = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoSavedBy))
        'Debug.Write("  CreateDate   = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoCreateDate))
        'Debug.Write("  SaveDate     = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoSaveDate))
        'Debug.Write("  CreateDate2  = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoCreateDate2))
        'Debug.Write("  SaveDate2    = " + swModel.SummaryInfo(SwConst.swSummInfoField_e.swSumInfoSaveDate2))
        Static saveModel As SldWorks.ModelDoc2
        Static passe As Boolean = False

        If (swModel Is saveModel) And (passe = True) Then
            Exit Sub  ' faudrait pas passer 2 fois dans le mettrenoms...
        Else
            saveModel = swModel
        End If
        passe = True


        'VideNom() ' on commence par enlever les noms (on suppose qu'il n'y en a pas déjà...)

        Dim s1 As SlyAreteVol
        For Each s1 In lst_AreteVolume
            s1.SaveNom()
        Next

        Dim s2 As SlyAreteCoque
        For Each s2 In lst_AreteCoque
            s2.SaveNom()
        Next

        Dim s3 As SlyAretePoutre
        For Each s3 In lst_AretePoutre
            s3.SaveNom()
        Next

        Dim s4 As SlyFaceVolume
        For Each s4 In lst_FaceVolume
            s4.SaveNom()
        Next

        Dim s5 As SlyFaceCoque
        For Each s5 In lst_FaceCoque
            s5.SaveNom()
        Next

        Dim s6 As SlySommetVolume
        For Each s6 In lst_SommetVolume
            s6.SaveNom()
        Next

        Dim s7 As SlySommetCoque
        For Each s7 In lst_SommetCoque
            s7.SaveNom()
        Next

        Dim s8 As SlySommetPoutre
        For Each s8 In lst_sommetPoutre
            s8.SaveNom()
        Next

    End Sub

    Public Sub videliste(Of T)(ByRef liste As Collections.Generic.List(Of T))
        liste.Clear()
    End Sub


    Public Sub videliste()
        lst_AreteVolume.Clear()
        lst_AreteCoque.Clear()
        lst_AretePoutre.Clear()
        lst_FaceVolume.Clear()
        lst_FaceCoque.Clear()
        lst_SommetVolume.Clear()
        lst_SommetCoque.Clear()
        lst_SommetCoque.Clear()
        lst_sommetPoutre.Clear()

    End Sub

    Public Function getNom(ByRef swEnt As SldWorks.Entity) As String
        getNom = swPart.GetEntityName(swEnt)
    End Function

    Public Function getNom(ByRef swFace As SldWorks.Face2) As String
        Dim swEnt As SldWorks.Entity
        swEnt = swFace
        getNom = swPart.GetEntityName(swEnt)
    End Function

    Public Function getNom(ByRef swArete As SldWorks.Edge) As String
        Dim swEnt As SldWorks.Entity
        swEnt = swArete
        getNom = swPart.GetEntityName(swEnt)
    End Function

    Public Function getNom(ByRef swSommet As SldWorks.Vertex) As String
        Dim swEnt As SldWorks.Entity
        swEnt = swSommet
        getNom = swPart.GetEntityName(swEnt)
    End Function

    Public Sub GererDossiers(ByRef nomDossier As String, ByRef NomFeature As String)
        ' déplace un feature dans un dossier ( et créé le dossier si ce n'est pas déjà fait)


        Static copienom As String
        Dim swFeat As SldWorks.Feature
        Dim ok As Boolean
        Dim j As Integer

        If Not StrComp(nomDossier, copienom) Then
            ' on commence par vérifier qu'il n'est pas déjà créé

            swFeat = swModel.FirstFeature

            Do While Not swFeat Is Nothing
                If swFeat.GetTypeName = "FtrFolder" And swFeat.Name = nomDossier Then GoTo suite
                swFeat = swFeat.GetNextFeature
            Loop

            'on mémorise tout ce qui est sélectionné
            Dim lst_selection As New Collection
            Dim selMgr As SldWorks.SelectionMgr
            selMgr = swModel.SelectionManager

            For j = 1 To selMgr.GetSelectedObjectCount
                lst_selection.Add(selMgr.GetSelectedObject5(j))
            Next j
            swModel.ClearSelection2(True)


            Dim folder As SldWorks.Feature
            Dim featMgr As SldWorks.FeatureManager
            featMgr = swModel.FeatureManager
            swModel.ClearSelection2(True)

            ' on doit mettre le folder à la fin sinon le feature risque d'être avant un parent
            j = 0
            swFeat = swModel.FeatureByPositionReverse(0)
            While Not ok
                j = j + 1
                If swFeat.GetTypeName = "ProfileFeature" Or swFeat.GetTypeName = "3DProfileFeature" Then swFeat = swModel.FeatureByPositionReverse(j) Else ok = True
            End While
            swFeat.Select(False)
            folder = featMgr.InsertFeatureTreeFolder2(1)
            If Not folder Is Nothing Then folder.Name = nomDossier
            folder = Nothing
            swPart.ReorderFeature(nomDossier, swFeat.Name)

            folder = Nothing

            ' on resélectionne les objets
            swModel.ClearSelection2(True)
            For j = 1 To lst_selection.Count
                lst_selection.Item(j).select(True)
            Next j

            swPart.ReorderFeature(NomFeature, nomDossier)
        End If

        '1 - le dossier est créé ou a déjà été créé.
        '2 - on redéplace le dossier à la fin.
suite:
        swFeat = swModel.FeatureByPositionReverse(0)
        swFeat.Select(False)
        j = 0
        While Not ok
            j = j + 1
            If swFeat.GetTypeName = "ProfileFeature" Or swFeat.GetTypeName = "3DProfileFeature" Then swFeat = swModel.FeatureByPositionReverse(j) Else ok = True
        End While
        swPart.ReorderFeature(nomDossier, swFeat.Name)
        ' 3- on déplace le feature dans le dossier

        swPart.ReorderFeature(NomFeature, nomDossier)
        'swModel.EditRebuild3()


    End Sub

    Public Function trouver(ByRef swface As SldWorks.Face2, ByRef tipe As Commun.tipe_e) As Object
        Dim face As SldWorks.Face2

        Select Case tipe
            Case tipe_e.Volume
                Dim sface As SlyFaceVolume
                For Each sface In lst_FaceVolume
                    'If swface Is sface.swFace Then trouver = sface : Exit Function

                    For Each face In sface.lst_Faces
                        If face Is swface Then Return sface
                    Next

                Next sface

            Case tipe_e.coque
                Dim sface As SlyFaceCoque
                For Each sface In lst_FaceCoque
                    'If swface Is sface.swFace Then trouver = sface : Exit Function
                    For Each face In sface.lst_Faces
                        If face Is swface Then Return sface
                    Next
                Next sface
        End Select
        Return Nothing ' devrait pas passer par ici...
    End Function

    Public Function trouver(ByRef swEnt As SldWorks.Entity) As Object
        Dim face As SldWorks.Face2
        Select Case swEnt.GetType()
            Case SwConst.swSelectType_e.swSelFACES
                Dim swface As SldWorks.Face2
                Dim f As SlyFaceVolume
                swface = swEnt
                For Each f In lst_FaceVolume
                    'If f.SwFace Is swface Then Return f
                    For Each face In f.lst_Faces
                        If face Is swface Then Return f
                    Next
                Next
                Dim f2 As SlyFaceCoque
                For Each f2 In lst_FaceCoque
                    'If f2.swFace Is swface Then Return f2
                    For Each face In f2.lst_Faces
                        If face Is swface Then Return f2
                    Next
                Next


            Case SwConst.swSelectType_e.swSelEDGES
                Dim swArete As SldWorks.Edge
                swArete = swEnt
                Dim test As Object
                test = Commun.trouver(swArete, tipe_e.Volume)
                If Not test Is Nothing Then Return test
                test = Commun.trouver(swArete, tipe_e.coque)
                If Not test Is Nothing Then Return test
                test = Commun.trouver(swArete, tipe_e.poutre)
                If Not test Is Nothing Then Return test


            Case SwConst.swSelectType_e.swSelVERTICES
                Dim swSommet As SldWorks.Vertex
                swSommet = swEnt

                Dim s1 As SlySommetVolume
                For Each s1 In lst_SommetVolume
                    If s1.swSommet Is swSommet Then Return s1
                Next

                Dim s2 As SlySommetCoque
                For Each s2 In lst_SommetCoque
                    If s2.swSommet Is swSommet Then Return s2
                Next

                Dim s3 As SlySommetPoutre
                For Each s3 In lst_sommetPoutre
                    If s3.swSommet Is swSommet Then Return s3
                Next

        End Select

        MsgBox("Entité non trouvée, dans commun.trouver")
        Return Nothing
    End Function

    ''' <summary>
    ''' Function qui trouve et retourne le pointeur d'une SlyArete arète si elle existe déjà
    ''' </summary>
    ''' <param name="swArete">L'arète à retrouver</param>
    ''' <param name="tipe">De quel type d'arrète il sagit</param>
    ''' <param name="Genlist">Une option pour accélérer le calcul dans certaines circonstances</param>
    ''' <returns>Le pointeur sur l'entité ou Nothing si elle est pas trouvée</returns>
    ''' <remarks></remarks>
    Public Function trouver(ByRef swArete As SldWorks.Edge, ByRef tipe As Commun.tipe_e, Optional ByRef Genlist As Boolean = False) As Object

        Select Case tipe
            Case tipe_e.Volume
                Dim s As SlyAreteVol
                For Each s In lst_AreteVolume
                    If swArete Is s.swArete Then Return s
                Next s

                ' ok, si on est ici c'est que l'on a pas trouvé l'arètequi nous intéresse, le pointeur a changé un peu...
                If Not Genlist Then
                    Dim Testarete As New SuperArete(swArete, True)
                    For Each s In lst_AreteVolume
                        If Testarete.Comparer(s.swArete) Then Return s
                    Next s
                End If

            Case tipe_e.coque
                Dim sArete As SlyAreteCoque
                For Each sArete In lst_AreteCoque
                    If swArete Is sArete.swArete Then trouver = sArete : Exit Function
                Next sArete

            Case tipe_e.poutre
                For Each sa As SlyAretePoutre In lst_AretePoutre
                    If sa.swArete Is swArete Then Return sa
                Next


            Case tipe_e.MiniPoutre
                MsgBox("Erreur, on ne devrait plus passer par ici!")
                'Dim sArete As SlyAretePoutre
                'Dim i As Integer
                'For i = 1 To lst_MiniPoutre.Count
                '    sArete = lst_MiniPoutre.Item(i)
                '    If swArete Is sArete.swArete Then trouver = sArete : Exit Function
                'Next i
        End Select
        Return Nothing
    End Function

    Public Function trouver(ByRef Arete As SuperArete, ByRef tipe As Commun.tipe_e, Optional ByRef Genlist As Boolean = False) As Object

        Select Case tipe
            Case tipe_e.Volume
                ' ok, si on est ici c'est que l'on a pas trouvé l'arètequi nous intéresse, le pointeur a changé un peu...
                If Not Genlist Then
                    Dim s As SlyAreteVol
                    For Each s In lst_AreteVolume
                        If Arete.Comparer(s.swArete) Then Return s
                    Next s
                End If

            Case tipe_e.coque
                Dim s As SlyAreteCoque
                For Each s In lst_AreteCoque
                    If Arete.Comparer(s.swArete) Then Return s
                Next s
        End Select

        Return Nothing
    End Function

    Public Function trouver(ByRef swSommet As SldWorks.Vertex, ByRef tipe As Commun.tipe_e) As Object

        Select Case tipe
            Case tipe_e.Volume
                Dim sSommet As SlySommetVolume
                For Each sSommet In lst_SommetVolume
                    If swSommet Is sSommet.swSommet Then trouver = sSommet : Exit Function
                Next sSommet

            Case tipe_e.coque
                Dim sSommet As SlySommetCoque
                For Each sSommet In lst_SommetCoque
                    If swSommet Is sSommet.swSommet Then trouver = sSommet : Exit Function
                Next sSommet

            Case tipe_e.poutre
                Dim sSommet As SlySommetPoutre
                For Each sSommet In lst_sommetPoutre
                    If swSommet Is sSommet.swSommet Then trouver = sSommet : Exit Function
                Next sSommet

        End Select
        Return Nothing
    End Function

    Public Sub VideNom()
        ' procédure qui retire le nom écrit sur les entités de solidworks

        Dim vNamedEntity As Object = Nothing
        Dim swEnt As SldWorks.Entity
        Dim retval As Boolean
        Dim i As Integer

        'If MsgBox("Essayer de vider les noms?", MsgBoxStyle.YesNo) = MsgBoxResult.No Then Exit Sub

        Try
            'MsgBox(swPart.MaterialIdName)
            vNamedEntity = swPart.GetNamedEntities
        Catch
            Dim nb As String
            Try
                nb = CStr(swPart.GetNamedEntitiesCount())
            Catch
                nb = "??"
            End Try

            MsgBox("Impossibilité d'obtenir la liste des entités déjà nomées.  On continue pareil..." & vbCr & "Il y a " & "??" & " entités qui ont un nom", MsgBoxStyle.Exclamation, "Sérieux problème!")
        End Try


        If IsNothing(vNamedEntity) Then Exit Sub
        For i = 0 To UBound(vNamedEntity)
            swEnt = vNamedEntity(i)
            Debug.Write(swPart.GetEntityName(swEnt))
            retval = swPart.DeleteEntityName(swEnt)
            If retval = False Then Debug.Write("Incapable d'effacer l'entité: " & swPart.GetEntityName(swEnt)) ' MsgBox(" Incapable d'effacer l'entité: " & swPart.GetEntityName(swEnt), vbCritical, "Problème dans VideNom()")
        Next i
    End Sub

    'function qui transfert les coordonnées du modèle en coodronnées pour le sketch
    Public Function TransfertModelSketch(ByRef sketch As SldWorks.Sketch, ByRef p() As Double) As Double()
        Dim MathUtil As SldWorks.MathUtility
        Dim MathP As SldWorks.MathPoint
        Dim MathTrans As SldWorks.MathTransform
        Dim p2() As Double
        MathUtil = swApp.GetMathUtility
        MathP = MathUtil.CreatePoint(p)

        MathTrans = sketch.ModelToSketchTransform
        MathP = MathP.MultiplyTransform(MathTrans)
        p2 = MathP.ArrayData
        Return p2
    End Function


    Public Function TransfertSketchToModel(ByRef sketch As SldWorks.Sketch, ByRef p() As Double) As Double()
        Dim MathUtil As SldWorks.MathUtility
        Dim MathP As SldWorks.MathPoint
        Dim MathTrans As SldWorks.MathTransform
        Dim p2() As Double
        Dim point(2) As Double
        Dim vPoint As Object
        MathUtil = swApp.GetMathUtility
        point(0) = p(0)
        point(1) = p(1)
        point(2) = 0
        vPoint = point
        MathP = MathUtil.CreatePoint(vPoint)

        MathTrans = sketch.ModelToSketchTransform
        MathTrans = MathTrans.Inverse
        MathP = MathP.MultiplyTransform(MathTrans)
        vPoint = MathP.ArrayData
        p2 = vPoint
        Return p2
    End Function


    Public Function DistanceMin(ByRef sCoque As SlyFaceCoque, ByRef sVolume As SlyFaceVolume) As Double
        Dim swFC As SldWorks.Face2
        Dim swFV As SldWorks.Face2
        Dim min As Double = 99999999999999
        Dim temp As Double

        For Each swFC In sCoque.lst_Faces
            For Each swFV In sVolume.lst_Faces
                temp = swModel.ClosestDistance(swFC, swFV, Nothing, Nothing)
                If temp < min Then min = temp
            Next
        Next
        Return min
    End Function


    Public Function Distance(ByRef somm As SldWorks.Vertex, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        vpoints = somm.GetPoint()
        dPoint = vpoints

        temp = (dPoint(0) - x) * (dPoint(0) - x) + (dPoint(1) - y) * (dPoint(1) - y) + (dPoint(2) - z) * (dPoint(2) - z)
        Return Math.Sqrt(temp)

    End Function

    Public Function Distance(ByRef Arete As SldWorks.Edge, ByRef x As Double, ByRef y As Double, ByRef z As Double) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        vpoints = Arete.GetClosestPointOn(x, y, z)
        dPoint = vpoints

        temp = (dPoint(0) - x) * (dPoint(0) - x) + (dPoint(1) - y) * (dPoint(1) - y) + (dPoint(2) - z) * (dPoint(2) - z)

        Return Math.Sqrt(temp)

    End Function

    Public Function Distance(ByRef Arete As SldWorks.Edge, ByRef P() As Double) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        vpoints = Arete.GetClosestPointOn(P(0), P(1), P(2))
        dPoint = vpoints

        temp = (dPoint(0) - P(0)) * (dPoint(0) - P(0)) + (dPoint(1) - P(1)) * (dPoint(1) - P(1)) + (dPoint(2) - P(2)) * (dPoint(2) - P(2))

        Return Math.Sqrt(temp)

    End Function


    Public Function Distance(ByRef Courbe As SldWorks.Curve, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        vpoints = Courbe.GetClosestPointOn(x, y, z)
        dPoint = vpoints

        temp = (dPoint(0) - x) * (dPoint(0) - x) + (dPoint(1) - y) * (dPoint(1) - y) + (dPoint(2) - z) * (dPoint(2) - z)

        Return Math.Sqrt(temp)
    End Function


    Public Function Distance(ByRef Face As SldWorks.Face2, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        vpoints = Face.GetClosestPointOn(x, y, z)
        dPoint = vpoints

        temp = (dPoint(0) - x) * (dPoint(0) - x) + (dPoint(1) - y) * (dPoint(1) - y) + (dPoint(2) - z) * (dPoint(2) - z)

        Return Math.Sqrt(temp)

    End Function


    Public Function Distance(ByRef Face As SldWorks.Face2, ByRef sommet As SldWorks.Vertex) As Double
        Dim vpoints As Object
        Dim dPoint() As Double
        Dim temp As Double
        Dim x As Double, y As Double, z As Double


        vpoints = sommet.GetPoint()
        dPoint = vpoints
        x = dPoint(0) : y = dPoint(1) : z = dPoint(2)

        vpoints = Face.GetClosestPointOn(x, y, z)
        dPoint = vpoints

        temp = (dPoint(0) - x) * (dPoint(0) - x) + (dPoint(1) - y) * (dPoint(1) - y) + (dPoint(2) - z) * (dPoint(2) - z)

        Return Math.Sqrt(temp)

    End Function


    Public Function distance(ByRef s1 As SldWorks.Vertex, ByRef s2 As SldWorks.Vertex) As Double

        Dim vpoints As Object
        Dim dPoint() As Double
        Dim dPoint2() As Double
        Dim temp As Double

        vpoints = s1.GetPoint()
        dPoint = vpoints

        vpoints = s2.GetPoint()
        dPoint2 = vpoints

        temp = (dPoint(0) - dPoint2(0)) * (dPoint(0) - dPoint2(0)) + (dPoint(1) - dPoint2(1)) * (dPoint(1) - dPoint2(1)) + (dPoint(2) - dPoint2(2)) * (dPoint(2) - dPoint2(2))
        Return Math.Sqrt(temp)

    End Function

    Public Function Distance(ByRef X1 As Double, ByRef Y1 As Double, ByRef Z1 As Double, ByRef X2 As Double, ByRef Y2 As Double, ByRef Z2 As Double) As Double
        Return Math.Sqrt((X2 - X1) ^ 2 + (Y2 - Y1) ^ 2 + (Z2 - Z1) ^ 2)
    End Function


    Public Function distance(ByRef P1() As Double, ByRef P2() As Double) As Double
        If Not UBound(P1) = 2 And Not UBound(P2) = 2 Then MsgBox("Cette fonction de distance ne marche qu'en 3D pour l'instant")
        Return Math.Sqrt((P1(0) - P2(0)) ^ 2 + (P1(1) - P2(1)) ^ 2 + (P1(2) - P2(2)) ^ 2)
    End Function


    Public Function distance(ByRef P1() As Double, ByRef s2 As SldWorks.Vertex) As Double

        Dim vpoints As Object
        Dim dPoint() As Double
        Dim dPoint2() As Double
        Dim temp As Double


        dPoint = P1

        vpoints = s2.GetPoint()
        dPoint2 = vpoints

        temp = (dPoint(0) - dPoint2(0)) * (dPoint(0) - dPoint2(0)) + (dPoint(1) - dPoint2(1)) * (dPoint(1) - dPoint2(1)) + (dPoint(2) - dPoint2(2)) * (dPoint(2) - dPoint2(2))
        Return Math.Sqrt(temp)

    End Function

    Public Function Distance(ByRef s1 As SlySommetPoutre, ByRef s2 As SlySommetCoque) As Double
        Return Distance(s1.swSommet, s2.swSommet)
    End Function

    Public Function Distance(ByRef s1 As SlySommetPoutre, ByRef s2 As SlySommetVolume) As Double
        Return Distance(s1.swSommet, s2.swSommet)
    End Function


    Public Function Distance(ByRef s1 As SlySommetPoutre, ByRef s2 As SlySommetPoutre) As Double
        Return Distance(s1.swSommet, s2.swSommet)
    End Function

    Public Function GetLongueurArete(ByRef swArete As SldWorks.Edge) As Double
        Dim swCourbe As SldWorks.Curve
        Dim temp As Object
        Dim T1 As Double, T2 As Double
        Dim sommet As SldWorks.Vertex
        Dim point As Object

        swCourbe = swArete.GetCurve

        sommet = swArete.GetStartVertex()

        If sommet IsNot Nothing Then
            point = sommet.GetPoint() : temp = swArete.GetParameter(point(0), point(1), point(2)) : T1 = temp(0)
            sommet = swArete.GetEndVertex() : point = sommet.GetPoint() : temp = swArete.GetParameter(point(0), point(1), point(2)) : T2 = temp(0)
            Return swCourbe.GetLength2(T1, T2)

        Else
            'l'arète est fermée.
            Dim params() As Double
            If swCourbe.IsCircle Then
                params = swCourbe.CircleParams
                Return params(7) * Pi * 2
            End If
            MsgBox("On demande la longueur d'une courbe fermée qui n'est pas un cercle... ce n'est pas encore programmé car ça ne devrait pas arriver.")
        End If

    End Function


    ''' <summary>
    ''' Function qui retourne le paramètreT du milieu de l'arète
    ''' </summary>
    ''' <param name="swSrete">L'arète en question</param>
    ''' <returns>Le paramètre T de l acourbe</returns>
    ''' <remarks>Si la courbe est fermée, la fonction retourne auqnd ême le T milieu.  i.e. T = pi</remarks>
    Public Function GetTMilieu(ByRef swArete As SldWorks.Edge) As Double
        Dim swCourbe As SldWorks.Curve
        Dim temp As Object
        Dim T1 As Double, T2 As Double
        Dim sommet As SldWorks.Vertex
        Dim point As Object

        swCourbe = swArete.GetCurve

        sommet = swArete.GetStartVertex()

        If sommet IsNot Nothing Then
            point = sommet.GetPoint() : temp = swArete.GetParameter(point(0), point(1), point(2)) : T1 = temp(0)
            sommet = swArete.GetEndVertex() : point = sommet.GetPoint() : temp = swArete.GetParameter(point(0), point(1), point(2)) : T2 = temp(0)
            Return (T1 + T2) / 2

        Else
            'l'arète est fermée.
            If swCourbe.IsCircle Then
                Return Pi
            End If
            MsgBox("On demande la longueur d'une courbe fermée qui n'est pas un cercle... ce n'est pas encore programmé car ça ne devrait pas arriver.")
        End If


    End Function

    'Procédure qui repère les arètes avec des atributs et leur met une couleur
    Public Sub ColorerAretes()
        ' on fait le tour des features pour avoir les poutres et les coques
        Dim feat As SldWorks.Feature
        Dim vSupprime As Object
        Dim bSupprime As Boolean
        Dim ent As SldWorks.Entity
        Dim attr As SldWorks.Attribute
        Dim swArete As SldWorks.Edge
        'RealConstant.RegisterAttribut()
        'RealConstant.RCCode.RegisterAttribut()

        swModel.EditRebuild3()

        feat = swPart.FirstFeature

        Do While Not feat Is Nothing

            vSupprime = feat.IsSuppressed
            bSupprime = CBool(vSupprime)
            If Not bSupprime Then  ' on vérifie que l'entité est pas supprimée

                Select Case feat.GetTypeName
                    Case "CompositeCurve", "3DSplineCurve", "Helix"  'le feature est une courbe libre

                        Dim refCourbe As SldWorks.ReferenceCurve

                        refCourbe = feat.GetSpecificFeature2
                        swArete = refCourbe.GetFirstSegment
                        Do While Not swArete Is Nothing
                            Try
                                ent = swArete
                                attr = ent.FindAttribute(Intersections.DefAttrRCP1, 0)
                                If Left(attr.GetName, 4) = "Mini" Then swArete.Display(2, 1, 0, 1, True) Else swArete.Display(2, 0, 1, 0, True)
                            Catch ex As Exception

                            End Try

                            swArete = Nothing
                            swArete = refCourbe.GetNextSegment
                        Loop
                End Select

            End If ' fin du if sur la suppression du feature
            feat = feat.GetNextFeature
        Loop
    End Sub

    ' procédure de débuggage qui place un point là où on le demande. (avec un sketch3D)
    Public Sub MettreUnPoint(ByRef x As Double, ByRef y As Double, ByRef z As Double, Optional ByVal Selection As Boolean = False)
        Dim point As SldWorks.SketchPoint
        swModel.Insert3DSketch2(True)
        point = swModel.CreatePoint2(x, y, z)
        swModel.Insert3DSketch2(False)
        'swModel.EditRebuild3()
        If Selection Then
            point.Select2(False, 0)
        End If
    End Sub

    Public Function MettreUnPoint(ByRef Plan As SldWorks.RefPlane, ByRef x As Double, ByRef y As Double, ByRef z As Double) As SldWorks.SketchPoint
        Dim swent As SldWorks.Entity
        Dim p(2) As Double
        p(0) = x
        p(1) = y
        p(2) = z
        swent = Plan
        swent.Select4(False, Nothing)
        swModel.InsertSketch2(True)
        p = Commun.TransfertModelSketch(swModel.GetActiveSketch2(), p)
        MettreUnPoint = swModel.CreatePoint2(p(0), p(1), p(2))
        swModel.InsertSketch2(False)
        swModel.EditRebuild3()
    End Function

    Public Function MettreUneLigne(ByRef Plan As SldWorks.RefPlane, ByRef x1 As Double, ByRef y1 As Double, ByRef z1 As Double, ByRef x2 As Double, ByRef y2 As Double, ByRef z2 As Double) As SldWorks.SketchSegment
        Dim swent As SldWorks.Entity
        Dim p(2) As Double, p2(2) As Double
        p(0) = x1 : p(1) = y1 : p(2) = z1
        p2(0) = x2 : p2(1) = y2 : p2(2) = z2
        swent = Plan
        swent.Select4(False, Nothing)
        swModel.InsertSketch2(True)
        p = Commun.TransfertModelSketch(swModel.GetActiveSketch2(), p)
        p2 = Commun.TransfertModelSketch(swModel.GetActiveSketch2(), p2)
        MettreUneLigne = swModel.CreateLine2(p(0), p(1), p(2), p2(0), p2(1), p2(2))
        swModel.InsertSketch2(False)
        swModel.EditRebuild3()
    End Function

    Public Function MettreUneLigne(ByRef face As SldWorks.Face2, ByRef x1 As Double, ByRef y1 As Double, ByRef z1 As Double, ByRef x2 As Double, ByRef y2 As Double, ByRef z2 As Double) As SldWorks.SketchSegment
        Dim swent As SldWorks.Entity
        Dim p(2) As Double, p2(2) As Double
        p(0) = x1 : p(1) = y1 : p(2) = z1
        p2(0) = x2 : p2(1) = y2 : p2(2) = z2
        swent = face
        swent.Select4(False, Nothing)
        swModel.InsertSketch2(True)
        p = Commun.TransfertModelSketch(swModel.GetActiveSketch2(), p)
        p2 = Commun.TransfertModelSketch(swModel.GetActiveSketch2(), p2)
        MettreUneLigne = swModel.CreateLine2(p(0), p(1), p(2), p2(0), p2(1), p2(2))
        swModel.InsertSketch2(False)
        swModel.EditRebuild3()
    End Function


    Public Sub EffacerAnnoEtCoord()
        Dim anno As SldWorks.Annotation
        Dim ent As SldWorks.Entity
        Dim prochainAnno As SldWorks.Annotation

        anno = swModel.GetFirstAnnotation2

        Do While Not anno Is Nothing
            anno.Select(False)
            prochainAnno = anno.GetNext3()
            swModel.EditDelete()
            anno = prochainAnno
        Loop


        ' parcours des features pour éliminer les Points3
        Dim feat As SldWorks.Feature
        Dim nextfeat As SldWorks.Feature
        feat = swPart.FirstFeature

        Do While Not feat Is Nothing
            If feat.GetTypeName = "CoordSys" Then
                nextfeat = feat.GetNextFeature
                ent = feat
                ent.Select2(False, Nothing)
                swModel.EditDelete()
                feat = nextfeat
            Else
                feat = feat.GetNextFeature()
            End If
        Loop


    End Sub

    Sub MettreAttributPourFaceInterne(ByRef swFaceInterne As SldWorks.Face2)
        ' Sub qui place l'attribut de faceinterne sur une face
        Dim attr As SldWorks.Attribute
        Dim swent As SldWorks.Entity
        Static no As Integer = 1
        Dim nom2 As String

        nom2 = "FaceInterne #" & no
        swent = swFaceInterne
        attr = swent.FindAttribute(Intersections.DefAttrFaceInterne, 0) ' si l'attribut existe déjà on pointe dessus.

        If attr Is Nothing Then attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFaceInterne, nom2, 0, 2) ' 0 = swThisconfig

        While attr Is Nothing
            nom2 = "FaceInterne" & CStr(no)
            attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFaceInterne, nom2, 0, 0)
            no += 1
        End While
        GererDossiers("FaceInternes", nom2)
        no += 1
    End Sub

    Private Function Ignorer(ByRef swArete As SldWorks.Edge) As Boolean
        Dim attr As SldWorks.Attribute
        Dim SwEnt As SldWorks.Entity
        Dim p As SldWorks.Parameter
        SwEnt = swArete
        attr = SwEnt.FindAttribute(DefAttrRCP1, 0)
        If attr Is Nothing Then Return False
        p = attr.GetParameter("D1")
        If p.GetDoubleValue = -9 Then Return True Else Return False
    End Function

    Public Sub GetMidPointSegment(ByVal seg As SldWorks.SketchSegment, ByRef x As Double, ByRef y As Double, ByRef z As Double)
        Dim curve As SldWorks.Curve
        Dim start As Double
        Dim pend As Double
        Dim isClosed As Boolean
        Dim isPeriodic As Boolean
        Dim milieu As Double
        Dim vXYZ As Object
        Dim xyz(2) As Double

        curve = seg.GetCurve
        curve.GetEndParams(start, pend, isClosed, isPeriodic)

        milieu = (pend + start) / 2

        vXYZ = curve.Evaluate(milieu)

        xyz = vXYZ

        x = xyz(0) : y = xyz(1) : z = xyz(2)

    End Sub

    Public Sub SelectFaceByName(ByVal Nom As String, Optional ByVal append As Boolean = False)
        Dim swent As SldWorks.Entity
        swent = swPart.GetEntityByName(Nom, SwConst.swSelectType_e.swSelFACES)
        swent.Select4(append, Nothing)
    End Sub

    Public Sub SelectAreteByName(ByVal Nom As String, Optional ByVal append As Boolean = False)
        Dim swent As SldWorks.Entity
        swent = swPart.GetEntityByName(Nom, SwConst.swSelectType_e.swSelEDGES)
        swent.Select4(append, Nothing)
    End Sub

    Public Sub SelectSommetByName(ByVal Nom As String, Optional ByVal append As Boolean = False)
        Dim swent As SldWorks.Entity
        swent = swPart.GetEntityByName(Nom, SwConst.swSelectType_e.swSelVERTICES)
        swent.Select4(append, Nothing)
    End Sub

    Public Function DessineCourbe(ByRef curve As SldWorks.Curve) As SldWorks.SketchSegment
        Dim modeler As SldWorks.Modeler
        Dim vp1 As Object : Dim P1() As Double
        Dim vp2 As Object : Dim P2() As Double
        Dim dir(2) As Double
        Dim sketchseg As SldWorks.SketchSegment = Nothing
        Dim i As Integer
        Dim Tmax As Double, Tmin As Double
        Dim ajout As Double

        Dim isPeriodic As Boolean : Dim isClosed As Boolean

        If curve.IsTrimmedCurve Then
            If curve.IsLine Then
                swModel.Insert3DSketch2(False)
                curve.GetEndParams(Tmin, Tmax, isClosed, isPeriodic)
                vp1 = curve.Evaluate(Tmin)
                vp2 = curve.Evaluate(Tmax)
                sketchseg = swModel.CreateLine2(vp1(0), vp1(1), vp1(2), vp2(0), vp2(1), vp2(2))
                swModel.Insert3DSketch2(False)
                Return sketchseg
            End If

        Else
            curve.GetEndParams(Tmin, Tmax, isClosed, isPeriodic)
            modeler = swApp.GetModeler
            swModel.Insert3DSketch2(False)
            ajout = (Tmax - Tmin) / 100
            vp1 = curve.Evaluate(Tmin) : P1 = vp1
            For i = 1 To 100
                vp2 = curve.Evaluate(Tmin + i * ajout) : P2 = vp2
                sketchseg = swModel.CreateLine2(P1(0), P1(1), P1(2), P2(0), P2(1), P2(2))
                P1 = P2
            Next i
            swModel.Insert3DSketch2(False)

            'modeler = swApp.GetModeler
            'For i = 1 To 100
            '    vp2 = curve.Evaluate(Tmin + i * ajout)
            '    modeler.CreateLine(vp1, vp2)
            '    vp1 = vp2
            'Next i
            Return sketchseg
        End If
        Return Nothing
    End Function

    Function AngleEntre2Faces(ByRef swface1 As SldWorks.Face2, ByRef swface2 As SldWorks.Face2, ByRef P() As Double) As Double
        ' function qui trouve l'angle entre 2 faces au point spécifié...
        Return AngleEntre2Faces(swface1, swface2, P(0), P(1), P(2))
    End Function

    Function AngleEntre2Faces(ByRef swface1 As SldWorks.Face2, ByRef swface2 As SldWorks.Face2, ByRef x As Double, ByRef y As Double, ByRef z As Double) As Double
        ' function qui trouve l'angle entre 2 faces au point spécifié...
        Dim swSurf As SldWorks.Surface
        Dim retval As Object
        Dim Normale1(2) As Double
        Dim Normale2(2) As Double

        swSurf = swface1.GetSurface
        retval = swSurf.EvaluateAtPoint(x, y, z)
        Normale1(0) = retval(0) : Normale1(1) = retval(1) : Normale1(2) = retval(2)

        swSurf = swface2.GetSurface
        retval = swSurf.EvaluateAtPoint(x, y, z)
        Normale2(0) = retval(0) : Normale2(1) = retval(1) : Normale2(2) = retval(2)

        Return Outils_Math.Angle2Vecteurs(Normale1, Normale2)
    End Function


    Public Sub Test()
        ' se déclenche quand on apuie sur le bouton 4

        Dim lst As New Collections.ObjectModel.Collection(Of SldWorks.Vertex)

        Intersections.RegisterAttribut()

        swModel.EditRebuild3()
        ' on fait le tour des features pour avoir les poutres et les coques
        Dim feat As SldWorks.Feature
        Dim vSupprime As Object
        Dim bSupprime As Boolean
        Dim attr As SldWorks.Attribute
        Dim swArete As SldWorks.Edge
        Dim swSommet1 As SldWorks.Vertex
        Dim swSommet2 As SldWorks.Vertex

        feat = swPart.FirstFeature

        Do While Not feat Is Nothing

            vSupprime = feat.IsSuppressed
            bSupprime = CBool(vSupprime)
            If Not bSupprime Then  ' on vérifie que l'entité est pas supprimée

                Select Case feat.GetTypeName
                    Case "CompositeCurve", "3DSplineCurve", "Helix"  'le feature est une courbe libre

                        Dim refCourbe As SldWorks.ReferenceCurve
                        refCourbe = feat.GetSpecificFeature2
                        swArete = refCourbe.GetFirstSegment
                        Do While Not swArete Is Nothing

                            If (Not Ignorer(swArete)) Then

                                swSommet1 = swArete.GetStartVertex
                                lst.Add(swSommet1)

                                If IsNothing(swSommet1) Then
                                    'MsgBox("On a une courbe sans sommet")
                                Else
                                    swSommet2 = swArete.GetEndVertex
                                    lst.Add(swSommet2)
                                End If
                            End If

                            swArete = Nothing
                            swArete = refCourbe.GetNextSegment

                        Loop

                    Case Else ' n'est pas un feature intéressant...
                        ' rien
                End Select
            End If ' fin du if sur la suppression du feature
            feat = feat.GetNextFeature
        Loop


        Dim swEnt As SldWorks.Entity
        For Each s As SldWorks.Vertex In lst
            swEnt = s
            attr = swEnt.FindAttribute(DefAttrDoublon, 0)
            If Not attr Is Nothing Then
                Dim p As SldWorks.Parameter = attr.GetParameter("Maitre")
                MsgBox(p.GetStringValue)
            End If
        Next


    End Sub


End Module
Revision:	40
Committed:	Mon Aug 20 21:30:28 2007 UTC (17 years, 9 months ago) by bournival
File size:	57657 byte(s)
Log Message:	Projet de these de Sylvain Bournival. Attention projet VB.