Auto-Clip Macro - Verx/Face Detection

Out of category
1

Hello, I'm looking to do automatic drawings but I'm stuck. The macro I made works but only for one part (the one I used to make the macro)

I'm looking for a way to make it work for any piece, but I don't know how to make it so that instead of giving the coordinates of the vertices of my piece or the face, it automatically detects it. So that no matter the size of the inserted part , the drawing can be done automatically.

 

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

 

2

Hello

There are several ways. For example, you can name the point, find the object with GetEntityByName (as you already do for faces TOP_FACE and RIGHT_FACE),

Then either:

 - select it on each view with SelectEntity, then set its "Mark" with SetSelectedObjectMark

 - or select it on each view with:

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

 

2 Likes
3

Thank you for your answer, I created a point that I named in my room, but I can't seem to select it to make my drilling table. Do you have an example if you have time? I'm a beginner in programming, I make my macros by picking from different examples already existing in general. 

4

If you attach the files, I'll look at this

5

Thank you very much, the plan is a standard horizontal A4 format drawing.

I enclose the SW part as well as the drilling table.


test_plan_auto.sldprt
6

.


drilling-coordinates-2020.sldholtbt
7

Try this.

Note: you will have to name the starting point of the coast

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

 

8

Hello, thank you for taking your time to do all this.

I can't figure out where I should call the "ORIGIN_POINT" in the room. Can you attach the document you have modified in your message?

9

In the same way that you named the TOP_FACE and RIGHT_FACE sides??

For example, select the vertex and run this:

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

 

1 Like
10

OLALA is perfect:) THANK YOU