Sélection par macro des diamètres avec ajustement dans mise en plan

Macro
1

Bonjour

 

Est t'il possible de sélectionner tous les Ø avec un ajustement dans les mises en plan

 

et de remplacer par ajustement avec tolérances?

Tolérances a mettre entre parenthèse en plus

 

Voici le bout de macro que j'ai débuté.

Je bloque sur la sélection de diamètre avec ajustement et remplacer par ajustement avec tolérances (entre parenthèse)

Merci d'avance de votre aide

Yannick


mep_-_selectionner_dimensions_avec_ajustement.swp
2

Bonjour. Essaye ça:

Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swDimTol As SldWorks.DimensionTolerance
'Dim swAnn As SldWorks.Annotation '
          
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Veuillez ouvrir un dessin": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocDRAWING Then MsgBox "Veuillez ouvrir un dessin": Exit Sub
Set swDraw = swModel
swModel.ClearSelection2 True
Set swView = swDraw.GetFirstView
While Not swView Is Nothing
    Set swDispDim = swView.GetFirstDisplayDimension5
    While Not swDispDim Is Nothing
        If swDispDim.GetType = swDimensionType_e.swRadialDimension Or swDispDim.GetType = swDimensionType_e.swDiameterDimension Then
           
            Set swDim = swDispDim.GetDimension2(0)
            Set swDimTol = swDim.Tolerance
            swDimTol.Type = swTolType_e.swTolFITWITHTOL
            swDispDim.ShowTolParenthesis = True
           
            ' Set swAnn = swDispDim.GetAnnotation '
            ' swAnn.Select3 True, Nothing '
        End If
        Set swDispDim = swDispDim.GetNext5
    Wend
    Set swView = swView.GetNextView
Wend
End Sub

 

3

Bonjour Jérome,

La macro à modifier tous les diamètres, je souhaite appliquer juste au diamètre avec ajustement déja renseigné

exemple ci dessous, application juste sur Ø33g6

 

 

yannick

4

Essaye ca:

Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swDimTol As SldWorks.DimensionTolerance
'Dim swAnn As SldWorks.Annotation '
           
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Veuillez ouvrir un dessin": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocDRAWING Then MsgBox "Veuillez ouvrir un dessin": Exit Sub
Set swDraw = swModel
swModel.ClearSelection2 True
Set swView = swDraw.GetFirstView
While Not swView Is Nothing
    Set swDispDim = swView.GetFirstDisplayDimension5
    While Not swDispDim Is Nothing
        If swDispDim.GetType = swDimensionType_e.swDiameterDimension Then
           
            Set swDim = swDispDim.GetDimension2(0)
            Set swDimTol = swDim.Tolerance
            If swDimTol.Type = swTolType_e.swTolFIT Or swDimTol.Type = swTolType_e.swTolFITWITHTOL Then
                swDimTol.Type = swTolType_e.swTolFITWITHTOL
                swDispDim.ShowTolParenthesis = True
            End If
           
            ' Set swAnn = swDispDim.GetAnnotation '
            ' swAnn.Select3 True, Nothing '
        End If
        Set swDispDim = swDispDim.GetNext5
    Wend
    Set swView = swView.GetNextView
Wend
End Sub

 

2 « J'aime »
5

Bonjour Jérome,

 

Merci pour ton retour, 

J'ai ajouté les dimensions linéaires dans le traitement (swDimensionType_e.swLinearDimension), pas de soucis ca fonctionne parfaitement

Par contre j'aurais une  question supplémentaire , est ce possible de gérer le nombre de décimal de la tolérance ( 3 par exemple)? 

 

Merci d'avance

 

Yannick

 

6

ajoute ca après "swDispDim.ShowTolParenthesis = True":

  swDispDim.SetPrecision3 3, 0, 3, 0
  swModel.ForceRebuild

voir ici pour plus d'info

7

Merci jérome

c'est exactement ce que je cherchais