Makro Auto-Clip - Wykrywanie wierzchołka/twarzy

Edouard_B · 4 Wrzesień 2020 13:07

Witam, szukam automatycznych rysunków, ale utknąłem. Makro, które zrobiłem, działa, ale tylko dla jednej części (tej, której użyłem do stworzenia makra)

Szukam sposobu, aby to działało dla dowolnego elementu, ale nie wiem, jak to zrobić, aby zamiast podawać współrzędne wierzchołków mojego kawałka lub twarzy, automatycznie je wykrywał. Dzięki temu bez względu na rozmiar wstawionej części , rysunek może zostać wykonany automatycznie.

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 · 4 Wrzesień 2020 16:25

Witam

Sposobów jest kilka. Na przykład możesz nazwać punkt, znaleźć obiekt za pomocą GetEntityByName (tak jak to już robisz w przypadku twarzy TOP_FACE i RIGHT_FACE),

Następnie:

- zaznacz go w każdym widoku za pomocą SelectEntity, a następnie ustaw jego "Znak" za pomocą SetSelectedObjectMark

- lub wybierz go w każdym widoku za pomocą:

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 · 7 Wrzesień 2020 06:04

Dziękuję za odpowiedź, stworzyłem punkt, który nazwałem w moim pokoju, ale nie mogę go wybrać, aby zrobić mój stół do wiercenia. Czy masz jakiś przykład, jeśli masz czas? Jestem początkujący w programowaniu, tworzę swoje makra, wybierając z różnych przykładów już istniejących.

JeromeP · 8 Wrzesień 2020 10:34

Jeśli załączysz pliki, przyjrzę się temu

Edouard_B · 8 Wrzesień 2020 12:41

Bardzo dziękuję, plan jest standardowym poziomym rysunkiem w formacie A4.

Załączam część programową oraz stół wiertniczy.

test_plan_auto.sldprt

Edouard_B · 8 Wrzesień 2020 12:46

.

współrzędne-wiercenia-2020.sldholtbt

JeromeP · 8 Wrzesień 2020 15:44

Spróbuj tego.

Uwaga: będziesz musiał podać punkt początkowy wybrzeża

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 · 9 Wrzesień 2020 06:05

Witam, dziękuję za poświęcenie czasu na zrobienie tego wszystkiego.

Nie wiem, gdzie powinienem zadzwonić do "ORIGIN_POINT" w pokoju. Czy możesz dołączyć zmodyfikowany dokument do swojej wiadomości?

JeromeP · 9 Wrzesień 2020 07:26

W ten sam sposób, w jaki nazwałeś strony TOP_FACE i RIGHT_FACE?

Na przykład wybierz wierzchołek i uruchom to:

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 · 9 Wrzesień 2020 08:13

OLALA jest idealna:) DZIĘKUJĘ