Set Dimensions to Mid-Tolerance Example (VBA)
This example shows how to iterate over all dimensions in a part and
set each of them to the middle of their tolerance range. This example
does not analyze the overall effect of varying tolerances. That operation
is beyond the scope of this example.
'----------------------------------------------------------------------------
' Problem:
' Dimensions
are usually nominal sizes.
' A
tolerance can also be specified and, in general,
' set
to upper and lower limits for the
' dimension.
'
' When
calculating CAM machining paths, it is desirable
' to
use a part that is in the middle of the tolerance
' ranges
so that the final machined part has
' the
highest probability of being within the
' overall
tolerances for the design.
'
'
' Preconditions:
' 1.
Part is open.
' 2.
Optionally, part has dimensions with tolerances.
'
' Postconditions:
' 1.
Derived configuration, based on the current
' configuration,
is created.
' 2.
Derived configuration is active configuration.
' 3. Derived configuration has all dimensions set to
' mid-tolerance.
' 4.
All tolerances are removed from dimensions.
'
' NOTE: All dimensions with a tolerance are set to
' mid-tolerance.
'---------------------------------------------------------------------------
Option Explicit
Function GetDimFactor _
( _
swApp
As SldWorks.SldWorks, _
swModel
As SldWorks.ModelDoc2, _
swDim
As SldWorks.Dimension _
) As Double
Const
PI As
Double = 3.14159265
Const
LEN_FACTOR As
Double = 1000#
Const
ANG_FACTOR As
Double = 180# / PI
Select
Case swDim.GetType
Case
swDimensionParamTypeDoubleLinear
GetDimFactor
= LEN_FACTOR
Case
swDimensionParamTypeDoubleAngular
GetDimFactor
= ANG_FACTOR
Case
Else
Debug.Assert
False
End
Select
End Function
Function GetDimString _
( _
swApp
As SldWorks.SldWorks, _
swModel
As SldWorks.ModelDoc2, _
swDim
As SldWorks.Dimension _
) As String
Const
LEN_STR As
String = " mm"
Const
ANG_STR As
String = " deg"
Select
Case swDim.GetType
Case
swDimensionParamTypeDoubleLinear
GetDimString
= LEN_STR
Case
swDimensionParamTypeDoubleAngular
GetDimString
= ANG_STR
Case
Else
Debug.Assert
False
End
Select
End Function
Sub SetDimensionToMidTolerance _
( _
swApp
As SldWorks.SldWorks, _
swModel
As SldWorks.ModelDoc2, _
swDim
As SldWorks.Dimension _
)
Dim
nRetval As
Long
Dim
nDimFactor As
Double
Dim
sDimStr As
String
Dim
vTolVal As
Variant
Dim
nOldVal As
Double
Dim
nNewVal As
Double
Dim
bRet As
Boolean
If
swDimensionDriving <> swDim.DrivenState
Or _
swDim.ReadOnly Then
Exit
Sub
End
If
'
Might have tolerance values stored from
'
previous tolerance type, so check current
'
tolerance type first
If
swTolNONE = swDim.GetToleranceType
Then
Exit
Sub
End
If
'
Mid-tolerance cannot make sense for a MIN/MAX tolerance
If
swTolMIN = swDim.GetToleranceType
Or _
swTolMAX
= swDim.GetToleranceType Then
Exit
Sub
End
If
vTolVal
= swDim.GetToleranceValues
If
IsEmpty(vTolVal) Then
Exit
Sub
End
If
nDimFactor
= GetDimFactor(swApp, swModel, swDim)
sDimStr
= GetDimString(swApp, swModel, swDim)
nOldVal
= swDim.GetSystemValue2("")
nNewVal
= nOldVal + (vTolVal(0) + vTolVal(1)) / 2#
Debug.Print
" -->"
Debug.Print
" Old
Value =
" & nOldVal * nDimFactor & sDimStr
Debug.Print
" New
Value =
" & nNewVal * nDimFactor & sDimStr
nRetval
= swDim.SetSystemValue3(nNewVal,
swSetValue_InThisConfiguration, Empty): Debug.Assert swSetValue_Successful
= nRetval
'
Changed to mid tolerance, so remove tolerance;
'
otherwise, will change dimension when run again
bRet
= swDim.SetToleranceType(swTolNONE):
Debug.Assert bRet
End Sub
Sub ProcessDimension _
( _
swApp
As SldWorks.SldWorks, _
swModel
As SldWorks.ModelDoc2, _
swDim
As SldWorks.Dimension _
)
Dim
nDimFactor As
Double
Dim
sDimStr As
String
Dim
vTolVal As
Variant
Dim
bRet As
Boolean
nDimFactor
= GetDimFactor(swApp, swModel, swDim)
sDimStr
= GetDimString(swApp, swModel, swDim)
Debug.Print
" "
& swDim.FullName
Debug.Print
" Value
=
" & swDim.GetSystemValue2("")
* nDimFactor & sDimStr
Debug.Print
" Driven
=
" & swDim.DrivenState
Debug.Print
" ReadOnly
=
" & swDim.ReadOnly
vTolVal
= swDim.GetToleranceValues
If
IsEmpty(vTolVal) Then
Debug.Print
" No
tolerance info"
Exit
Sub
End
If
Debug.Print
" TolType
=
" & swDim.GetToleranceType
Debug.Print
" FitType
=
" & swDim.GetToleranceFitValues
Debug.Print
" MaxTol
=
" & vTolVal(1) * nDimFactor & sDimStr
Debug.Print
" MinTol
=
" & vTolVal(0) * nDimFactor & sDimStr
End Sub
Sub ProcessMassProps _
( _
swApp
As SldWorks.SldWorks, _
swModel
As SldWorks.ModelDoc2 _
)
Dim
swDocExt As
SldWorks.ModelDocExtension
Dim
swMass As
SldWorks.MassProperty
Set
swDocExt = swModel.Extension
Set
swMass = swDocExt.CreateMassProperty
Debug.Print
" Mass
=
" & swMass.Mass * 1000#
& " g"
Debug.Print
" Surface
Area =
" & swMass.SurfaceArea
* 1000000# & " mm^2"
Debug.Print
" Volume
=
" & swMass.Volume * 1000000000#
& " mm^3"
Debug.Print
" Density
=
" & swMass.Density &
" kg/m^3"
Debug.Print
" CenterOfMass
=
(" & swMass.CenterOfMass(0)
* 1000# & ", " & swMass.CenterOfMass(1)
* 1000# & ", " & swMass.CenterOfMass(2)
* 1000# & ") mm"
End Sub
Sub main()
Dim
swApp As
SldWorks.SldWorks
Dim
swModel As
SldWorks.ModelDoc2
Dim
swConf As
SldWorks.Configuration
Dim
swMidConf As
SldWorks.Configuration
Dim
swConfMgr As
SldWorks.ConfigurationManager
Dim
swFeat As
SldWorks.feature
Dim
swDispDim As
SldWorks.DisplayDimension
Dim
swDim As
SldWorks.Dimension
Dim
bRet As
Boolean
Set
swApp = Application.SldWorks
Set
swModel = swApp.ActiveDoc
Set
swConf = swModel.GetActiveConfiguration
Set
swConfMgr = swModel.ConfigurationManager
Set
swMidConf = swConfMgr.AddConfiguration(
_
swConf.Name & " - mid tolerance",
_
"mid
tolerance", _
"mid
tolerance", _
1,
_
swConf.Name, _
"mid
tolerance"): Debug.Assert Not swMidConf Is Nothing
Set
swFeat = swModel.FirstFeature
Debug.Print
"File = " & swModel.GetPathName
Debug.Print
" Nominal
Tolerance:"
ProcessMassProps
swApp, swModel
Debug.Print
" -----------------------------"
Do
While Not swFeat Is Nothing
Debug.Print
" "
& swFeat.Name
Set
swDispDim = swFeat.GetFirstDisplayDimension
Do
While Not swDispDim Is Nothing
Set
swDim = swDispDim.GetDimension
ProcessDimension
swApp, swModel, swDim
SetDimensionToMidTolerance
swApp, swModel, swDim
Set
swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
Set
swFeat = swFeat.GetNextFeature
Loop
bRet
= swModel.ForceRebuild3(False):
Debug.Assert bRet
Debug.Print
" Middle
Tolerance:"
ProcessMassProps
swApp, swModel
Debug.Print
" -----------------------------"
End Sub