Macro selection of diameters with adjustment in drawing

Macro
1

Hello

 

Is it possible to select all the Ø with an adjustment in the drawings?

 

and replace with fit with tolerances?

Tolerances to be put in parenthesis in addition

 

Here is the bit of macro I started.

I'm stuck on the diameter selection with adjustment and replace with adjustment with tolerances (in brackets)

Thank you in advance for your help

Yannick


mep_-_selectionner_dimensions_avec_ajustement.swp
2

Hello. Try this:

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

Hello Jerome,

The macro to modify all the diameters, I want to apply just to the diameter with adjustment already filled in

example below, application just on Ø33g6

 

 

yannick

4

Try this:

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

Hello Jerome,

 

Thank you for your feedback, 

I added the linear dimensions in the processing (swDimensionType_e.swLinearDimension), no worries it works perfectly

On the other hand I have an  additional question, is it possible to manage the number of decimal places of the tolerance ( 3 for example)? 

 

Thanks in advance

 

Yannick

 

6

add this after "swDispDim.ShowTolParenthesis = True":

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

See here for more info

7

Thank you Jerome

It's exactly what I was looking for