Auto-Clip-Makro - Verx-/Gesichtserkennung

Edouard.B · 4. September 2020 um 13:07

Hallo, ich möchte automatische Zeichnungen erstellen, aber ich komme nicht weiter. Das Makro, das ich erstellt habe, funktioniert, aber nur für einen Teil (den, den ich verwendet habe, um das Makro zu erstellen)

Ich suche nach einer Möglichkeit, es für jedes Stück zum Laufen zu bringen, aber ich weiß nicht, wie ich es so machen soll, dass es automatisch erkannt wird, anstatt die Koordinaten der Eckpunkte meines Stücks oder der Fläche anzugeben. So kann die Zeichnung unabhängig von der Größe des eingefügten Teils automatisch erstellt werden.

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. September 2020 um 16:25

Hallo

Es gibt mehrere Möglichkeiten. Sie können z. B. den Punkt benennen, das Objekt mit GetEntityByName suchen (wie Sie es bereits für Gesichter TOP_FACE und RIGHT_FACE tun),

Dann entweder:

- Wählen Sie es in jeder Ansicht mit SelectEntity aus und setzen Sie dann seine "Markierung" mit SetSelectedObjectMark

- oder wählen Sie es in jeder Ansicht aus mit:

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. September 2020 um 06:04

Vielen Dank für Ihre Antwort, ich habe einen Punkt erstellt, den ich in meinem Zimmer benannt habe, aber ich kann ihn anscheinend nicht auswählen, um meinen Bohrtisch zu erstellen. Haben Sie ein Beispiel, wenn Sie Zeit haben? Ich bin ein Anfänger in der Programmierung, ich mache meine Makros, indem ich aus verschiedenen Beispielen auswähle, die bereits im Allgemeinen existieren.

JeromeP · 8. September 2020 um 10:34

Wenn Sie die Dateien anhängen, werde ich mir das ansehen

Edouard.B · 8. September 2020 um 12:41

Vielen Dank, der Plan ist eine Standardzeichnung im horizontalen A4-Format.

Ich lege sowohl den SW-Teil als auch den Bohrtisch bei .

test_plan_auto.sldprt

Edouard.B · 8. September 2020 um 12:46

.

bohr-koordinaten-2020.sldholtbt

JeromeP · 8. September 2020 um 15:44

Versuchen Sie das.

Hinweis: Sie müssen den Startpunkt der Küste nennen

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. September 2020 um 06:05

Hallo, danke, dass Sie sich die Zeit genommen haben, all dies zu tun.

Ich weiß nicht, wo ich das "ORIGIN_POINT" im Raum nennen soll. Können Sie das Dokument, das Sie in Ihrer Nachricht geändert haben, anhängen?

JeromeP · 9. September 2020 um 07:26

Genauso wie du die TOP_FACE und RIGHT_FACE Seiten genannt hast??

Wählen Sie z. B. den Scheitelpunkt aus, und führen Sie Folgendes aus:

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. September 2020 um 08:13

OLALA ist perfekt:) VIELEN DANK