Macro pour cacher les fraisages problème sur une pièce

Bonjour,

J'ai une macro avec une partie qui cache les fraisages sur une mep, cette macro développée grâce à @JeromeP  sur ce sujet:https://www.lynkoa.com/forum/solidworks/macro-cacher-les-cercle-de-fraisure-assistance-de-per%C3%A7age

Sauf que cette macro me supprime 2 perçages qui ne sont pourtant pas des fraisages et ne devrait donc pas être détecté.

Je joint la pièce et la mep qui pose problème ainsi que le code utilisée:

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



 

Je croyais au départ que la position symétrique des 2 cercle faisait qu'il ne détectait pas le - sur l'une des 2 positions et qu'il estime donc que les 2 cercle sont superposée j'ai donc ajouté 2 autre cercle de façon symétrique à l'origine de la pièce et ceux là sont traités comme il faut (ignoré)

Donc je ne comprends plus vraiment si quelqu'un à une idée sur le sujet.


pb_trou_2.zip

Bonjour il nous maque la class1 qui n'est pas defini

Bonjour il nous maque la class1 qui n'est pas defini

Exact:

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

 

Bonjour, Le problème est que la pièce n'est pas parallèle a un des plans du repère.

Essaye ca:

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 « J'aime »

Parfaitement fonctionnel effectivement. Ce que je comprends pas c'est que le problème est très ponctuel, sut la m^me face je reproduit 2 autres perçages du même Ø et le soucis ne se reproduit pas.

En essayant de reproduire le soucis sur une autre pièce avec aucune face // au repère et de multiple perçage impossible de reproduire le soucis.

Néanmoins le code avec la fonction pour remettre la vue // au repère si j'ai bien compris, est parfaitement fonctionnel et devrais résoudre ce soucis très ponctuel (2 pièces sur + de 5000 depuis la mise en place de cette macro).

 

Je remplace le code précédent par celui-ci réponse dans 5000 pièces!

 

Merci

1 « J'aime »