Macro mise en plan automatique - Détection sommet/face

Edouard_B · Septembre 4, 2020, 1:07

Bonjour je cherche à faire des mise en plan automatique mais je suis bloqué. la macro que j'ai faites marche mais seulement pour une seule pièce (celle que je me suis servis pour faire la macro)

je cherche un moyen pour que cela marche pour n'importe quel pièce, mais je ne sais pas comment faire pour que au lieu que je donne les coordonnées des sommets de ma pièces ou la face, il le détecte automatiquement. Pour que peu importe la taille de la pièce insérée, la mise en plan puisse ce faire automatiquement.

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.DrawingDoc
Dim boolstatus As Boolean
Dim Part As SldWorks.ModelDoc2
Dim pathName As String

Const MODELE As String = "CHEMIN MISE EN PLAN\.drwdot"
Const TABLE As String = "CHEMIN TABLE DE PERCAGE\.sldholtbt"
Const TOP_FACE_NAME As String = "TOP_FACE"
Const RIGHT_FACE_NAME As String = "RIGHT_FACE"

Sub main()

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox "Cette Macro ne fonctionne que sur une pièce", vbCritical, "AVERTISSEMENT"
        End
    End If
    
    If swModel.GetType <> swDocPART Then
        MsgBox "Cette Macro ne fonctionne que sur une pièce", vbCritical, "AVERTISSEMENT"
        End
    End If
    
    swModel.GetTitle
       
    pathName = swModel.GetPathName
    COMPOSANT = pathName
    'Debug.Print COMPOSANT
    
    Set spec = swApp.GetOpenDocSpec(COMPOSANT)
    Set Part = swApp.OpenDoc7(spec)
    Set Draw = swApp.NewDocument(MODELE, 12, 0.21, 0.297)

     
    Set swDraw = swApp.ActiveDoc
    
    Dim swCompModel As SldWorks.PartDoc
    Set swCompModel = swApp.OpenDoc6(COMPOSANT, swDocumentTypes_e.swDocPART, swOpenDocOptions_e.swOpenDocOptions_Silent, "", 0, 0)
        
    swApp.ActivateDoc3 COMPOSANT, False, 0, 0
    
    Dim swFace As SldWorks.Entity
    
    Set swFace = swCompModel.GetEntityByName(TOP_FACE_NAME, swSelectType_e.swSelFACES)
    If Not swFace Is Nothing Then
        swFace.SelectByMark False, 1
    End If

    Set swFace = swCompModel.GetEntityByName(RIGHT_FACE_NAME, swSelectType_e.swSelFACES)
    If Not swFace Is Nothing Then
        swFace.SelectByMark True, 2
    End If
    
    Dim swView As SldWorks.view
       
    swApp.ActivateDoc3 swDraw.GetTitle, False, 0, 0

    Set swView = swDraw.CreateRelativeView(COMPOSANT, 0.1, 0.13, swRelativeViewCreationDirection_e.swRelativeViewCreationDirection_FRONT, swRelativeViewCreationDirection_e.swRelativeViewCreationDirection_RIGHT)

    Set Part = swDraw
    
    Part.ClearSelection2 True
   
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.0995, 0.13, 0, True, 0, Nothing, 0)
    Set myView = Part.CreateUnfoldedViewAt3(0.16, 0.13, 0, False)
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.0995, 0.13, 0, True, 0, Nothing, 0)
    Set myView = Part.CreateUnfoldedViewAt3(0.04, 0.13, 0, False)
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.0995, 0.13, 0, True, 0, Nothing, 0)
    Set myView = Part.CreateUnfoldedViewAt3(0.0995, 0.18, 0, False)
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.0995, 0.13, 0, True, 0, Nothing, 0)
    Set myView = Part.CreateUnfoldedViewAt3(0.0995, 0.08, 0, False)


    'Vue aux. Droite
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.16, 0.127, 0, True, 16, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "VERTEX", 0.1609, 0.097, 0, True, 1, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.16, 0.127, 0, True, 2, Nothing, 0)

    'Vue aux. Gauche
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.04, 0.127, 0, True, 16, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "VERTEX", 0.039, 0.097, 0, True, 1, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.04, 0.127, 0, True, 2, Nothing, 0)
    
    'Vue aux. Haut
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.102, 0.18, 0, True, 16, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "VERTEX", 0.055, 0.18095, 0, True, 1, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.102, 0.18, 0, True, 2, Nothing, 0)
    
    'Vue aux. Bas
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.102, 0.08, 0, True, 16, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "VERTEX", 0.055, 0.079, 0, True, 1, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.102, 0.08, 0, True, 2, Nothing, 0)
    
    'Vue principale Dessus
    boolstatus = Part.Extension.SelectByID2("", "DRAWINGVIEW", 0.0995, 0.13, 0, True, 16, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "VERTEX", 0.055, 0.097, 0, True, 1, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.0995, 0.13, 0, True, 2, Nothing, 0)
    
    'Dim myView As Object
    Set myView = Part.SelectionManager.GetSelectedObjectsDrawingView2(1, -1)
    Dim myHoleTable As Object
    

    Set myHoleTable = myView.InsertHoleTable2(False, 0.291, 0.205, 2, "A", TABLE)
    Part.ClearSelection2 True
    boolstatus = Part.ActivateSheet("Sheet1")

    'Set swDraw = swModel
    Set swView = Part.CreateDrawViewFromModelView3(ModelPath, "*Dimétrique", 0.053, 0.032, 0)
    boolstatus = Part.Extension.SelectByID2("", "FACE", 0.053, 0.032, 0, True, 2, Nothing, 0)
    swDraw.ViewDisplayShaded
    swDraw.ViewModelEdges

End Sub

JeromeP · Septembre 4, 2020, 4:25

Bonjour,

Il y a plusieurs moyen. Tu peux par exemple nommer le point, trouver l'objet avec GetEntityByName (comme tu le fait déja pour les faces TOP_FACE et RIGHT_FACE),

Ensuite soit :

- le sélectionner sur chaque vue avec SelectEntity, puis définir sa "Mark" avec SetSelectedObjectMark

- ou le sélectionner sur chaque vue avec :

SelectInView myView1, swEntPt

Sub SelectInView(byval swView As SldWorks.view, byval swEnt As SldWorks.Entity)
  Dim swSelMgr As SldWorks.SelectionMgr
  Dim swSelData As SldWorks.SelectData

  Set swSelMgr = swDraw.SelectionManager
  Set swSelData = swSelMgr.CreateSelectData
  swSelData.View = swView
  swSelData.Mark = 1
  swEnt.Select4 True, swSelData
End sub

Edouard_B · Septembre 7, 2020, 6:04

Merci pour votre réponse, j'ai créé un point que j'ai nommé dans ma pièce, mais je n'arrive pas à le sélectionner pour faire ma table de perçage. Est-ce que vous auriez un exemple si vous avez du temps ? je suis débutant dans la programmation, je fais mes macros en piochant dans différents exemple déjà existant en général.

JeromeP · Septembre 8, 2020, 10:34

Si tu attache les fichiers , je regarderai ca

Edouard_B · Septembre 8, 2020, 12:41

Merci beaucoup, le plan est une mise en plan standard horizontal format A4.

je vous joins la pièce SW ainsi que la table de perçage.

test_plan_auto.sldprt

Edouard_B · Septembre 8, 2020, 12:46

.

percage-coordonnees-2020.sldholtbt

JeromeP · Septembre 8, 2020, 3:44

Essaye ca.

Note: il faudra nommer le point de départ de côte

Option Explicit
Dim swModel As SldWorks.ModelDoc2
Dim swModelDraw As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr

Sub main()
    Const DrawingTemplate As String = "CHEMIN MISE EN PLAN\.drwdot"
    Const TABLE As String = "CHEMIN TABLE DE PERCAGE\.sldholtbt"
    Const TOP_FACE_NAME As String = "TOP_FACE"
    Const RIGHT_FACE_NAME As String = "RIGHT_FACE"
    
    Dim swApp As SldWorks.SldWorks
    Dim swDraw As SldWorks.DrawingDoc
    Dim swViews(5) As SldWorks.View
    Dim swSelData As SldWorks.SelectData
    Dim swEnt As SldWorks.Entity
    Dim myHoleTable As SldWorks.HoleTableAnnotation
    Dim i As Integer
    Dim Xpos As Single
    Dim Ypos As Single
    Dim PartPath As String
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then MsgBox "Ouvrir une pièce": Exit Sub
    If swModel.GetType <> swDocPART Then MsgBox "Ouvrir une pièce": Exit Sub
    Set swSelMgr = swModel.SelectionManager
    Set swSelData = swSelMgr.CreateSelectData

    PartPath = swModel.GetPathName
    
    ' create Relative view
    Set swEnt = swModel.GetEntityByName(TOP_FACE_NAME, swSelectType_e.swSelFACES)
    If swEnt Is Nothing Then MsgBox "Face de dessus non trouvée": Exit Sub
    swSelData.Mark = 1
    swEnt.Select4 False, swSelData

    Set swEnt = swModel.GetEntityByName(RIGHT_FACE_NAME, swSelectType_e.swSelFACES)
    If swEnt Is Nothing Then MsgBox "Face de droite non trouvée": Exit Sub
    swSelData.Mark = 2
    swEnt.Select4 True, swSelData
    
    Set swModelDraw = swApp.NewDocument(DrawingTemplate, 12, 0.21, 0.297)
    Set swDraw = swModelDraw
    Set swViews(0) = swDraw.CreateRelativeView(PartPath, 0.1, 0.13, swRelativeViewCreationDirection_e.swRelativeViewCreationDirection_FRONT, swRelativeViewCreationDirection_e.swRelativeViewCreationDirection_RIGHT)

    ' create side views
    For i = 1 To 4
        Select Case i
        Case 1
            Xpos = 0.16: Ypos = 0.13
        Case 2
            Xpos = 0.04: Ypos = 0.13
        Case 3
            Xpos = 0.0995: Ypos = 0.18
        Case 4
            Xpos = 0.0995: Ypos = 0.08
        End Select
        swModelDraw.Extension.SelectByID2 swViews(0).Name, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0
        Set swViews(i) = swDraw.CreateUnfoldedViewAt3(Xpos, Ypos, 0, False)
    Next

    ' create HoleTable
    swModelDraw.ClearSelection2 True
    For i = 0 To 4
        SelectInView swViews(i)
    Next
    Set myHoleTable = swViews(0).InsertHoleTable2(False, 0.291, 0.205, 2, "A", TABLE)

    ' create dimétrique view
    Set swViews(5) = swModelDraw.CreateDrawViewFromModelView3(PartPath, "*Dimétrique", 0.053, 0.032, 0)
    swViews(5).SetDisplayMode3 False, swDisplayMode_e.swSHADED, False, True

End Sub

Sub SelectInView(ByVal swView As SldWorks.View)

    'select view
    swModelDraw.Extension.SelectByID2 swView.Name, "DRAWINGVIEW", 0, 0, 0, True, 16, Nothing, 0
    
    'select origine
    Dim swEnt As SldWorks.Entity
    Dim swSelData As SldWorks.SelectData
    Set swEnt = swModel.GetEntityByName("ORIGIN_POINT", swSelectType_e.swSelVERTICES)
    If swEnt Is Nothing Then MsgBox "Point d'origine non trouvé": Exit Sub
    Set swSelData = swSelMgr.CreateSelectData
    swSelData.View = swView
    swSelData.Mark = 1
    swEnt.Select4 True, swSelData

    'select largest face
    Dim vComps As Variant
    Dim swComp As SldWorks.Component2
    Dim vFaces As Variant
    Dim vFace As Variant
    Dim swFace As SldWorks.Face2
    Dim Area As Double
    
    vComps = swView.GetVisibleComponents
    Set swComp = vComps(0)
    vFaces = swView.GetVisibleEntities2(swComp, swViewEntityType_e.swViewEntityType_Face)
    If IsEmpty(vFaces) Then Exit Sub
    For Each vFace In vFaces
        Set swFace = vFace
        If swFace.GetArea > Area Then
            Area = swFace.GetArea
            Set swEnt = swFace
        End If
    Next
    swSelData.Mark = 2
    swEnt.Select4 True, swSelData

End Sub

Edouard_B · Septembre 9, 2020, 6:05

Bonjour merci d'avoir pris de votre temps pour faire tout ça.

je n'arrive pas à savoir ou est ce que je dois nommer le "ORIGIN_POINT" dans la pièce. est ce que vous pouvez joindre la pièce que vous avez modifié dans votre message ?

JeromeP · Septembre 9, 2020, 7:26

De la même façon que tu as nommé les faces TOP_FACE et RIGHT_FACE ??

Par exemple, sélectionne le sommet et lance ca:

Option Explicit
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swPart As SldWorks.PartDoc
    Dim swVertex As SldWorks.Vertex
    Dim swSelMgr As SldWorks.SelectionMgr
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swPart = swModel
    Set swSelMgr = swModel.SelectionManager
    Set swVertex = swSelMgr.GetSelectedObject6(1, -1)
    If swVertex Is Nothing Then MsgBox "selectionner un sommet": Exit Sub
    swPart.SetEntityName swVertex, "ORIGIN_POINT"
    Debug.Print "Nom du sommet: " & swPart.GetEntityName(swVertex)
End Sub

Edouard_B · Septembre 9, 2020, 8:13

OLALA c'est parfait :) MERCI