Macro om problemen met frezen op een onderdeel te verbergen

Hallo

Ik heb een macro met een onderdeel dat het frezen op een MEP verbergt, deze macro is ontwikkeld dankzij @JeromeP  over dit onderwerp:https://www.lynkoa.com/forum/solidworks/macro-cacher-les-cercle-de-fraisure-assistance-de-per%C3%A7age

Behalve dat deze macro 2 gaten verwijdert die niet frezen en dus niet gedetecteerd mogen worden.

Ik voeg het onderdeel en de MEP toe die het probleem veroorzaakt, evenals de gebruikte code:

Option Explicit
Sub HideFraisage()
Dim swapp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim vComps As Variant
Dim vComp As Variant
Dim Comp As SldWorks.Component2
Dim vEdges As Variant
Dim vEdge As Variant
Dim swEdge As SldWorks.edge
Dim swCurve As SldWorks.Curve
Dim IsClosed As Boolean
Dim pos As String
Dim CurveParam As Variant
Dim Cercle As Class1
Dim monCercle As Class1
Dim Cercles As Collection
Dim Resultat As Variant
Dim m As Double
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
Set swDraw = swModel

Set swView = swDraw.GetFirstView.GetNextView
'Set swView = swDraw.ActiveDrawingView
'If swView Is Nothing Then
    'MsgBox "Selectionner une vue"
    'Exit Sub
'End If

'Ajout SD pour récuperer les valeures de la Bounding Box (Longueur Largeur épaisseur)
Dim swPartModel As SldWorks.ModelDoc2
Set swPartModel = swView.ReferencedDocument
Resultat = GetPreciseBoundingBox(swPartModel)
    
' Fin de l'ajout

'On r
Set Cercles = New Collection
vComps = swView.GetVisibleComponents
For Each vComp In vComps
    Set Comp = vComp
    vEdges = swView.GetVisibleEntities(Comp, swViewEntityType_e.swViewEntityType_Edge)
    For Each vEdge In vEdges
        Set swEdge = vEdge
        Set swCurve = swEdge.GetCurve
        If swCurve.IsCircle Then
            swCurve.GetEndParams Empty, Empty, IsClosed, Empty
            If IsClosed Then
                CurveParam = swCurve.CircleParams
                pos = ""
                If Round(CurveParam(3), 5) = 0 Then pos = pos & Round(CurveParam(0), 5) & "-"
                If Round(CurveParam(4), 5) = 0 Then pos = pos & Round(CurveParam(1), 5) & "-"
                If Round(CurveParam(5), 5) = 0 Then pos = pos & Round(CurveParam(2), 5) & "-"
                'Debug.Print pos
                Set Cercle = New Class1
                Cercle.pos = pos
                Cercle.dia = (Round(CurveParam(6), 10)) * 1000
                Set Cercle.edge = swEdge
                Cercles.Add Cercle
            End If
        End If
    Next
Next
swModel.ClearSelection2 True
For Each monCercle In Cercles
    For Each Cercle In Cercles
            
        If Cercle.pos = monCercle.pos And Cercle.dia < monCercle.dia And (monCercle.dia * 2) < (Resultat(1) - 2) Then
               
          monCercle.edge.Select4 True, Nothing
          
        
        End If
    Next
Next
'On cache le cercle
swDraw.HideEdge
swModel.ForceRebuild3 False
swModel.ClearSelection2 True
End Sub

Function GetPreciseBoundingBox(part As SldWorks.PartDoc) As Variant
    Dim dBox(2) As Double
    Dim vBodies As Variant
    vBodies = part.GetBodies2(swBodyType_e.swSolidBody, True)
    Dim minX As Double
    Dim minY As Double
    Dim minZ As Double
    Dim maxX As Double
    Dim maxY As Double
    Dim maxZ As Double
    Dim First As Integer, Last As Long
    Dim j, k As Long
    Dim temp As Double
    

     If Not IsEmpty(vBodies) Then
        Dim i As Integer
        For i = 0 To UBound(vBodies)
            Dim swBody As SldWorks.Body2
            Set swBody = vBodies(i)
            Dim x As Double
            Dim y As Double
            Dim z As Double
            swBody.GetExtremePoint 1, 0, 0, x, y, z
            If i = 0 Or x > maxX Then maxX = x

            swBody.GetExtremePoint -1, 0, 0, x, y, z
            If i = 0 Or x < minX Then minX = x

            swBody.GetExtremePoint 0, 1, 0, x, y, z
            If i = 0 Or y > maxY Then maxY = y

            swBody.GetExtremePoint 0, -1, 0, x, y, z
            If i = 0 Or y < minY Then minY = y

            swBody.GetExtremePoint 0, 0, 1, x, y, z
            If i = 0 Or z > maxZ Then maxZ = z
            
            swBody.GetExtremePoint 0, 0, -1, x, y, z
            If i = 0 Or z < minZ Then minZ = z
        Next
    End If
    x = (maxX - minX) * 1000
    y = (maxY - minY) * 1000
    z = (maxZ - minZ) * 1000
    'Debug.Print "x=" & x
    'Debug.Print "y=" & y
    'Debug.Print "z=" & z
    dBox(0) = x: dBox(1) = y: dBox(2) = z


        First = LBound(dBox)
    Last = UBound(dBox)
    
    For j = First To Last - 1
        For k = j + 1 To Last
            If dBox(j) > dBox(k) Then
                temp = dBox(k)
                dBox(k) = dBox(j)
                dBox(j) = temp
           End If
        Next k
    Next j
        
      
    'Debug.Print "Longueur:" & dBox(2)
    'Debug.Print "Largeur:" & dBox(1)
    'Debug.Print "Epaisseur:" & dBox(0)
    
    GetPreciseBoundingBox = dBox
    
End Function



 

Ik dacht aanvankelijk dat de symmetrische positie van de 2 cirkels betekende dat het de - op een van de 2 posities niet detecteerde en dat het daarom gelooft dat de 2 cirkels over elkaar heen liggen, dus heb ik 2 andere cirkels symmetrisch toegevoegd aan de oorsprong van het onderdeel en deze worden behandeld zoals ze zouden moeten zijn (genegeerd)

Dus ik begrijp niet echt of iemand een idee heeft over het onderwerp.


pb_trou_2.zip

Hallo, we missen de klasse1 die niet is gedefinieerd

Hallo, we missen de klasse1 die niet is gedefinieerd

Juist:

'Class1:'
Public edge As SldWorks.Entity
Public pos As String
Public dia As Single

 

Hallo, Het probleem is dat het onderdeel niet evenwijdig is aan een van de vlakken van het coördinatensysteem.

Probeer het volgende:

Option Explicit
Dim swapp As SldWorks.SldWorks
Sub HideFraisage()

Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim vComps As Variant
Dim vComp As Variant
Dim Comp As SldWorks.Component2
Dim vEdges As Variant
Dim vEdge As Variant
Dim swEdge As SldWorks.edge
Dim swCurve As SldWorks.Curve
Dim IsClosed As Boolean
Dim CurveParam As Variant
Dim Cercle As Class1
Dim monCercle As Class1
Dim Cercles As Collection
Dim Resultat As Variant
Dim m As Double
Set swapp = Application.SldWorks
Set swModel = swapp.ActiveDoc
Set swDraw = swModel

Set swView = swDraw.GetFirstView.GetNextView
'Set swView = swDraw.ActiveDrawingView
'If swView Is Nothing Then
    'MsgBox "Selectionner une vue"
    'Exit Sub
'End If

'Ajout SD pour récuperer les valeures de la Bounding Box (Longueur Largeur épaisseur)
Dim swPartModel As SldWorks.ModelDoc2
Set swPartModel = swView.ReferencedDocument
Resultat = GetPreciseBoundingBox(swPartModel)

Dim swDrawingToViewXForm As SldWorks.MathTransform
Set swDrawingToViewXForm = drawingToViewTransform(swView).Inverse
Dim swMathUtil As SldWorks.MathUtility
Set swMathUtil = swapp.GetMathUtility
Dim swViewXform As SldWorks.MathTransform
Set swViewXform = swView.ModelToViewTransform
Dim swViewPt As SldWorks.MathPoint
Dim nPtData(2) As Double
Dim vPtData As Variant

Set Cercles = New Collection
vComps = swView.GetVisibleComponents
For Each vComp In vComps
    Set Comp = vComp
    vEdges = swView.GetVisibleEntities(Comp, swViewEntityType_e.swViewEntityType_Edge)
    For Each vEdge In vEdges
        Set swEdge = vEdge
        Set swCurve = swEdge.GetCurve
        If swCurve.IsCircle Then
            swCurve.GetEndParams Empty, Empty, IsClosed, Empty
            If IsClosed Then
                CurveParam = swCurve.CircleParams
                nPtData(0) = CurveParam(0)
                nPtData(1) = CurveParam(1)
                nPtData(2) = CurveParam(2)
                vPtData = nPtData
                Set swViewPt = swMathUtil.CreatePoint(vPtData)
                Set swViewPt = swViewPt.MultiplyTransform(swViewXform)
                Set swViewPt = swViewPt.MultiplyTransform(swDrawingToViewXForm)
                Set Cercle = New Class1
                Cercle.posX = Round(swViewPt.ArrayData(0) * 1000, 2)
                Cercle.posY = Round(swViewPt.ArrayData(1) * 1000, 2)
                Debug.Print Cercle.posX & vbTab & Cercle.posY
                Cercle.dia = Round(CurveParam(6) * 2000, 3)
                Set Cercle.edge = swEdge
                Cercles.Add Cercle
            End If
        End If
    Next
Next
swModel.ClearSelection2 True
For Each monCercle In Cercles
    'Debug.Print monCercle.posX & vbTab & monCercle.posY & vbTab & monCercle.dia
    For Each Cercle In Cercles
        If Cercle.posX = monCercle.posX And Cercle.posY = monCercle.posY And Cercle.dia < monCercle.dia And monCercle.dia < (Resultat(1) - 2) Then
          monCercle.edge.Select4 True, Nothing
        End If
    Next
Next
'On cache le cercle
swDraw.HideEdge
swModel.ForceRebuild3 False
swModel.ClearSelection2 True
End Sub

Function drawingToViewTransform(swView As SldWorks.View) As SldWorks.MathTransform
    Dim swMathUtil  As SldWorks.MathUtility
    Dim transformData(15) As Double
    Set swMathUtil = swapp.GetMathUtility
    transformData(0) = Cos(swView.Angle)
    transformData(1) = Sin(swView.Angle)
    transformData(2) = 0#
    transformData(3) = -Sin(swView.Angle)
    transformData(4) = Cos(swView.Angle)
    transformData(5) = 0#
    transformData(6) = 0#
    transformData(7) = 0#
    transformData(8) = 1#
    transformData(9) = swView.Position(0)
    transformData(10) = swView.Position(1)
    transformData(11) = 0#
    transformData(12) = swView.ScaleDecimal
    transformData(13) = 0#
    transformData(14) = 0#
    transformData(15) = 0#
Set drawingToViewTransform = swMathUtil.CreateTransform(transformData)
End Function

'class1
Public edge As SldWorks.Entity
Public posX As Double
Public posY As Double
Public dia As Single

 

1 like

Perfect functioneel inderdaad. Wat ik niet begrijp, is dat het probleem erg punctueel is, op hetzelfde ^e gezicht reproduceer ik 2 andere piercings van dezelfde Ø en het probleem komt niet meer terug.

Wanneer u probeert het probleem te reproduceren op een ander onderdeel zonder gezicht // bij de markering en meerdere gaten, is het onmogelijk om het probleem te reproduceren.

Desalniettemin is de code met de functie om de weergave // terug naar de marker te zetten, als ik het goed begrijp, perfect functioneel en zou dit zeer punctuele probleem moeten oplossen (2 stuks van de + 5000 sinds de implementatie van deze macro).

 

Ik vervang de vorige code door dit antwoord in 5000 stukjes!

 

Bedankt

1 like