Macro selectie van diameters met aanpassing in tekening

Macro
1

Hallo

 

Is het mogelijk om alle Ø te selecteren met een aanpassing in de tekeningen?

 

en vervangen door pasvorm met toleranties?

Toleranties die bovendien tussen haakjes moeten worden geplaatst

 

Hier is het stukje macro dat ik ben begonnen.

Ik zit vast aan de diameterselectie met afstelling en vervang door afstelling met toleranties (tussen haakjes)

Bij voorbaat dank voor uw hulp

Yannick


mep_-_selectionner_dimensions_avec_ajustement.swp
2

Hallo. Probeer het volgende:

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

Hallo Hiëronymus,

De macro om alle diameters te wijzigen, wil ik alleen toepassen op de diameter met de aanpassing al ingevuld

voorbeeld hieronder, toepassing alleen op Ø33g6

 

 

Yannick

4

Probeer het volgende:

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 likes
5

Hallo Hiëronymus,

 

Bedankt voor je feedback, 

Ik heb de lineaire afmetingen toegevoegd aan de verwerking (swDimensionType_e.swLinearDimension), geen zorgen, het werkt perfect

Aan de andere kant heb ik een  aanvullende vraag, is het mogelijk om het aantal decimalen van de tolerantie te beheren ( bijvoorbeeld 3)? 

 

Bij voorbaat dank

 

Yannick

 

6

voeg dit toe na "swDispDim.ShowTolParenthesis = True":

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

Zie hier voor meer info

7

Dank je wel Jerome

Het is precies wat ik zocht