Autodimension All Sketches Example (VBA)

This example shows how to autodimension all sketches in a part.

 

'--------------------------------------

'

' Preconditions:

'       (1) Part is open.

'       (2) Part contains at least one sketch.

'       (3) Sketch contains some sketch segments or geometry.

'

' Postconditions: If successful, then all sketches have dimensions added to them.

'

' Notes: Return code from ISketch::AutoDimension2 is output to the

'        debug window. Examine this window if the call fails.

'

'-------------------------------------

Option Explicit

Public Enum swConstrainedStatus_e

    swUnknownConstraint = 1

    swUnderConstrained = 2

    swFullyConstrained = 3

    swOverConstrained = 4

    swNoSolution = 5

    swInvalidSolution = 6

    swAutosolveOff = 7

End Enum

Public Enum swSketchSegments_e

    swSketchLINE = 0

    swSketchARC = 1

    swSketchELLIPSE = 2

    swSketchSPLINE = 3

    swSketchTEXT = 4

    swSketchPARABOLA = 5

End Enum

Public Enum swAutodimEntities_e

    swAutodimEntitiesAll = 1

    swAutodimEntitiesSelected = 2

End Enum

Public Enum swAutodimMark_e

    swAutodimMarkEntities = &H1

    swAutodimMarkHorizontalDatum = &H2

    swAutodimMarkVerticalDatum = &H4

End Enum

Public Enum swAutodimScheme_e

    swAutodimSchemeBaseline = 1

    swAutodimSchemeOrdinate = 2

    swAutodimSchemeChain = 3

    swAutodimSchemeCenterline = 4

End Enum

Public Enum swAutodimHorizontalPlacement_e

    swAutodimHorizontalPlacementBelow = -1

    swAutodimHorizontalPlacementAbove = 1

End Enum

Public Enum swAutodimVerticalPlacement_e

    swAutodimVerticalPlacementLeft = -1

    swAutodimVerticalPlacementRight = 1

End Enum

Public Enum swAutodimStatus_e

    swAutodimStatusSuccess = 0

    swAutodimStatusBadOptionValue = 1

    swAutodimStatusNoActiveDoc = 2

    swAutodimStatusDocTypeNotSupported = 3

    swAutodimStatusNoActiveSketch = 4

    swAutodimStatus3DSketchNotSupported = 5

    swAutodimStatusSketchIsEmpty = 6

    swAutodimStatusSketchIsOverDefined = 7

    swAutodimStatusNoEntities = 8

    swAutodimStatusEntitiesNotValid = 9

    swAutodimStatusCenterlineNotAllowed = 10

    swAutodimStatusDatumNotSupplied = 11

    swAutodimStatusDatumNotUnique = 12

    swAutodimStatusDatumNotValidType = 13

    swAutodimStatusDatumLineNotCenterline = 14

    swAutodimStatusDatumLineNotVertical = 15

    swAutodimStatusDatumLineNotHorizontal = 16

    swAutodimStatusAlgorithmFailed = 17

End Enum

Const swTnProfileFeature        As String = "ProfileFeature"

Const nTolerance                As Double = 0.00000001

Sub FindAllUnderConstrainedSketches _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    sSketchNameArr() As String _

)

    Dim swPart                          As SldWorks.PartDoc

    Dim swFeat                          As SldWorks.feature

    Dim swSketch                        As SldWorks.Sketch

    Dim bRet                            As Boolean

    

    Set swPart = swModel

    Set swFeat = swPart.FirstFeature

    

    Do While Not swFeat Is Nothing

        If swTnProfileFeature = swFeat.GetTypeName Then

            Set swSketch = swFeat.GetSpecificFeature2

            

            If swUnderConstrained = swSketch.GetConstrainedStatus Then

                sSketchNameArr(UBound(sSketchNameArr)) = swFeat.Name

            

                ReDim Preserve sSketchNameArr(UBound(sSketchNameArr) + 1)

            End If

        End If

        

        Set swFeat = swFeat.GetNextFeature

    Loop

    

    ' Remove last empty sketch name

    ReDim Preserve sSketchNameArr(UBound(sSketchNameArr) - 1)

End Sub

Function GetAllSketchLines _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.Sketch _

) As Variant

    Dim vSketchSegArr                   As Variant

    Dim vSketchSeg                      As Variant

    Dim swSketchSeg                     As SldWorks.SketchSegment

    Dim swSketchCurrLine                As SldWorks.SketchLine

    Dim swSketchLineArr()               As SldWorks.SketchLine

    ReDim swSketchLineArr(0)

    

    vSketchSegArr = swSketch.GetSketchSegments

    If Not IsEmpty(vSketchSegArr) Then

        For Each vSketchSeg In vSketchSegArr

            Set swSketchSeg = vSketchSeg

            

            If swSketchLINE = swSketchSeg.GetType Then

                Set swSketchCurrLine = swSketchSeg

                Set swSketchLineArr(UBound(swSketchLineArr)) = swSketchCurrLine

            

                ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) + 1)

            End If

        Next

    End If

    If 0 = UBound(swSketchLineArr) Then

        ' No straight lines in this sketch

        GetAllSketchLines = Empty

        Exit Function

    End If

    

    ' Remove last empty sketch line

    ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) - 1)

    

    GetAllSketchLines = swSketchLineArr

End Function

    

Function GetSketchPoint _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.Sketch, _

    swSketchPt As SldWorks.SketchPoint _

) As Boolean

    Dim vSketchPtArr                    As Variant

    vSketchPtArr = swSketch.GetSketchPoints

    If Not IsEmpty(vSketchPtArr) Then

        ' Use first point

        Set swSketchPt = vSketchPtArr(0)

                    

        GetSketchPoint = True

        Exit Function

    End If

    

    GetSketchPoint = False

End Function

Function FindVerticalOrigin _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.Sketch, _

    swSketchSegVert As SldWorks.SketchSegment, _

    swSketchPtVert As SldWorks.SketchPoint _

) As Boolean

    Dim vSketchLineArr                  As Variant

    Dim vSketchLine                     As Variant

    Dim swSketchCurrLine                As SldWorks.SketchLine

    Dim swStartPt                       As SldWorks.SketchPoint

    Dim swEndPt                         As SldWorks.SketchPoint

    

    ' Try to get first vertical line

    vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)

    If Not IsEmpty(vSketchLineArr) Then

        For Each vSketchLine In vSketchLineArr

            Set swSketchCurrLine = vSketchLine

            Set swStartPt = swSketchCurrLine.GetStartPoint2

            Set swEndPt = swSketchCurrLine.GetEndPoint2

            

            If Abs(swStartPt.X - swEndPt.X) < nTolerance Then

                Set swSketchSegVert = swSketchCurrLine

                

                FindVerticalOrigin = True

                Exit Function

            End If

        Next

    End If

    

    ' Try to get the first point

    FindVerticalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtVert)

End Function

Function FindHorizontalOrigin _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.Sketch, _

    swSketchSegHoriz As SldWorks.SketchSegment, _

    swSketchPtHoriz As SldWorks.SketchPoint _

) As Boolean

    Dim vSketchLineArr                  As Variant

    Dim vSketchLine                     As Variant

    Dim swSketchCurrLine                As SldWorks.SketchLine

    Dim swStartPt                       As SldWorks.SketchPoint

    Dim swEndPt                         As SldWorks.SketchPoint

    

    ' Try to get first horizontal line

    vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)

    If Not IsEmpty(vSketchLineArr) Then

        For Each vSketchLine In vSketchLineArr

            Set swSketchCurrLine = vSketchLine

            Set swStartPt = swSketchCurrLine.GetStartPoint2

            Set swEndPt = swSketchCurrLine.GetEndPoint2

            

            If Abs(swStartPt.Y - swEndPt.Y) < nTolerance Then

                Set swSketchSegHoriz = swSketchCurrLine

                

                FindHorizontalOrigin = True

                Exit Function

            End If

        Next

    End If

    

    ' Try to get the first point

    FindHorizontalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtHoriz)

End Function

Function AutoDimensionSketch _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.Sketch _

) As Long

    Dim swFeat                          As SldWorks.feature

    Dim swSketchSegHoriz                As SldWorks.SketchSegment

    Dim swSketchPtHoriz                 As SldWorks.SketchPoint

    Dim swSketchSegVert                 As SldWorks.SketchSegment

    Dim swSketchPtVert                  As SldWorks.SketchPoint

    Dim bRet                            As Boolean

            

    If False = FindHorizontalOrigin(swApp, swModel, swSketch, swSketchSegHoriz, swSketchPtHoriz) Then

        AutoDimensionSketch = swAutodimStatusDatumLineNotHorizontal

        Exit Function

    End If

    

    If False = FindVerticalOrigin(swApp, swModel, swSketch, swSketchSegVert, swSketchPtVert) Then

        AutoDimensionSketch = swAutodimStatusDatumLineNotVertical

        Exit Function

    End If

    

    Set swFeat = swSketch

    

    bRet = swFeat.Select2(False, 0)

    Debug.Assert bRet

    

    ' Editing sketch clears selections

    swModel.EditSketch

    

    ' Reselect sketch segments for autodimensioning

    If Not swSketchSegVert Is Nothing Then

        ' Vertical line is for horizontal datum

        bRet = swSketchSegVert.Select4(True, Nothing)

    ElseIf Not swSketchPtHoriz Is Nothing Then

             bRet = swSketchPtHoriz.Select4(True, Nothing)

    ElseIf Not swSketchPtVert Is Nothing Then

            ' Use any sketch point for horizontal datum

             bRet = swSketchPtVert.Select4(True, Nothing)

            

    End If

    Debug.Assert bRet

    

    If Not swSketchSegHoriz Is Nothing Then

        ' Horizontal line is for vertical datum

        bRet = swSketchSegHoriz.Select4(True, Nothing)

    ElseIf Not swSketchPtVert Is Nothing Then

        bRet = swSketchPtVert.Select4(True, Nothing)

    ElseIf Not swSketchPtHoriz Is Nothing Then

            ' Use any sketch point for vertical datum

            bRet = swSketchPtHoriz.Select4(True, Nothing)

    End If

    Debug.Assert bRet

    

    ' No straight lines, probably contains circles,

    ' so use sketch points for datums

    If IsEmpty(GetAllSketchLines(swApp, swModel, swSketch)) Then

        If Not swSketchPtHoriz Is Nothing Then

            bRet = swSketchPtHoriz.Select4(False, Nothing)

        ElseIf Not swSketchPtVert Is Nothing Then

            bRet = swSketchPtVert.Select4(False, Nothing)

        End If

    End If

    Debug.Assert bRet

    

    AutoDimensionSketch = swSketch.AutoDimension2( _

                            swAutodimEntitiesAll, _

                            swAutodimSchemeBaseline, _

                            swAutodimHorizontalPlacementBelow, _

                            swAutodimSchemeBaseline, _

                            swAutodimVerticalPlacementLeft)

    

    ' Redraw so dimensions are displayed immediately

    swModel.GraphicsRedraw2

    

    ' Exit sketch edit

    ' Leave rebuild to later

    swModel.InsertSketch2 False

End Function

Sub main()

    Dim swApp                           As SldWorks.SldWorks

    Dim swModel                         As SldWorks.ModelDoc2

    Dim swPart                          As SldWorks.PartDoc

    Dim sSketchNameArr()                As String

    Dim sSketchName                     As Variant

    Dim swFeat                          As SldWorks.feature

    Dim swSketch                        As SldWorks.Sketch

    Dim nRetVal                         As Long

    Dim i                               As Long

    Dim bRet                            As Boolean

    

    Set swApp = CreateObject("SldWorks.Application")

    Set swModel = swApp.ActiveDoc

    Set swPart = swModel

    

    Debug.Print "File = " & swModel.GetPathName

    

    ReDim sSketchNameArr(0)

    

    FindAllUnderConstrainedSketches swApp, swModel, sSketchNameArr

    

    For Each sSketchName In sSketchNameArr

        Set swFeat = swPart.FeatureByName(sSketchName)

        Set swSketch = swFeat.GetSpecificFeature

        

        nRetVal = AutoDimensionSketch(swApp, swModel, swSketch)

        

        Debug.Print "  " & sSketchName & " = " & nRetVal

    Next

    

    ' Rebuild after modifying sketches

    bRet = swModel.EditRebuild3

    Debug.Assert bRet

End Sub