Auto-Clip Macro - Verx/Gezicht Detectie

Edouard_B · 4 september 2020 om 13:07

Hallo, ik ben op zoek naar automatische tekeningen, maar ik zit vast. De macro die ik heb gemaakt werkt, maar slechts voor één deel (degene die ik heb gebruikt om de macro te maken)

Ik ben op zoek naar een manier om het voor elk stuk te laten werken, maar ik weet niet hoe ik het zo moet maken dat in plaats van de coördinaten van de hoekpunten van mijn stuk of het gezicht te geven, het het automatisch detecteert. Zodat ongeacht de grootte van het ingebrachte onderdeel , de tekening automatisch kan worden gedaan.

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 om 16:25

Hallo

Er zijn verschillende manieren. U kunt bijvoorbeeld het punt een naam geven, het object zoeken met GetEntityByName (zoals u al doet voor gezichten TOP_FACE en RIGHT_FACE),

Dan ofwel:

- selecteer het in elke weergave met SelectEntity en stel vervolgens de "Mark" in met SetSelectedObjectMark

- of selecteer het in elke weergave met:

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 om 06:04

Bedankt voor je antwoord, ik heb een punt gemaakt dat ik in mijn kamer heb genoemd, maar ik kan het niet selecteren om mijn boortafel te maken. Heb je een voorbeeld als je tijd hebt? Ik ben een beginner in programmeren, ik maak mijn macro's door te kiezen uit verschillende voorbeelden die al in het algemeen bestaan.

JeromeP · 8 september 2020 om 10:34

Als je de bestanden bijvoegt, zal ik hiernaar kijken

Edouard_B · 8 september 2020 om 12:41

Hartelijk dank, het plan is een standaard horizontale tekening op A4-formaat.

Ik sluit zowel het SW-gedeelte als de boortafel in.

test_plan_auto.sldprt

Edouard_B · 8 september 2020 om 12:46

.

boren-coördinaten-2020.sldholtbt

JeromeP · 8 september 2020 om 15:44

Probeer dit eens.

Let op: je zult het startpunt van de kust moeten noemen

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 om 06:05

Hallo, bedankt dat je de tijd hebt genomen om dit allemaal te doen.

Ik weet niet waar ik de "ORIGIN_POINT" in de kamer moet noemen. Kunt u het document dat u hebt gewijzigd bij uw bericht voegen?

JeromeP · 9 september 2020 om 07:26

Op dezelfde manier waarop je de TOP_FACE en RIGHT_FACE zijkanten hebt genoemd??

Selecteer bijvoorbeeld het hoekpunt en voer het volgende uit:

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 om 08:13

OLALA is perfect:) BEDANKT