Insert DXF File and Add Dimensions Example (VBA)

This example shows how to insert a DXF file on a pre-selected plane or face and how to then autodimension it.

 

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

'

' Preconditions:

'          (1) Part is open.    

'          (2) Plane or face on which to insert DXF file is selected.

'

' Postconditions:

'          (1) DXF/DWG file is added as sketch.

'          2) Sketch is autodimensioned.

'

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

Option Explicit

 

Const nTolerance                As Double = 0.00000001

 

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.GetSketchPoints2

    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

    

    ' 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

    

    ' Get 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

    

    ' 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

    

    ' Get first point

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

End Function

 

Function AutoDimensionSketch _

( _

    swApp As SldWorks.SldWorks, _

    swModel As SldWorks.ModelDoc2, _

    swSketch As SldWorks.sketch, _

    swSelData As SldWorks.SelectData _

) 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 with correct marks for auto-dimensioning

    If Not swSketchSegVert Is Nothing Then

        ' Vertical line is for horizontal datum

        bRet = swSketchSegVert.Select4(True, swSelData)

    ElseIf Not swSketchPtHoriz Is Nothing Then

            bRet = swSketchPtHoriz.Select4(True, swSelData)

    ElseIf Not swSketchPtVert Is Nothing Then

            ' Use any sketch point for horizontal datum

            bRet = swSketchPtVert.Select4(True, swSelData)

    End If

    Debug.Assert bRet

    

    If Not swSketchSegHoriz Is Nothing Then

        ' Horizontal line is for vertical datum

        bRet = swSketchSegHoriz.Select4(True, swSelData)

    ElseIf Not swSketchPtVert Is Nothing Then

        bRet = swSketchPtVert.Select4(True, swSelData)

    ElseIf Not swSketchPtHoriz Is Nothing Then

            ' Use any sketch point for vertical datum

            bRet = swSketchPtHoriz.Select4(True, swSelData)

    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, swSelData)

        ElseIf Not swSketchPtVert Is Nothing Then

            bRet = swSketchPtVert.Select4(False, swSelData)

        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()

    Const sDwgFileName                  As String = "d:\samples\rainbow.dxf"

    

    Dim swApp                           As SldWorks.SldWorks

    Dim swModel                         As SldWorks.modelDoc

    Dim swFeatMgr                       As SldWorks.FeatureManager

    Dim swFeat                          As SldWorks.feature

    Dim swSketch                        As SldWorks.sketch

    Dim swSelMgr                        As SldWorks.SelectionMgr

    Dim swSelData                       As SldWorks.SelectData

    Dim nRetVal                         As Long

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

    Set swFeatMgr = swModel.FeatureManager

    Set swFeat = swFeatMgr.InsertDwgOrDxfFile(sDwgFileName)

    Set swSketch = swFeat.GetSpecificFeature2

    Set swSelMgr = swModel.SelectionManager

    Set swSelData = swSelMgr.CreateSelectData

    

    nRetVal = AutoDimensionSketch(swApp, swModel, swSketch, swSelData)

    

    ' Rebuild to update sketch

    swModel.EditRebuild3

End Sub

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