More 'Goodies'

Sketches merged into the 3D sketch
Sketches merged into the 3D sketch

This VBA macro merges the selected sketches (3D and 3D) into a single 3D sketch using SOLIDWORKS API. This macro is using convert entities API to copy the entities from the source sketches to a target sketch.


  • Sketches in the assembly or drawings components are also supported
  • Relations and dimensions from the source sketch are not copied to a target sketch
  • Sketches are merged to an active 3D sketch, or new 3D sketch is created automatically

Use this macro in conjunction with Select Features By Type to select all sketches to be merged.

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    If Not swModel Is Nothing Then
        MergeSelectedSketches swModel
        MsgBox "Please open model"
    End If
End Sub

Sub MergeSelectedSketches(model As SldWorks.ModelDoc2)
    Dim swSketch As SldWorks.sketch
    If Not model.SketchManager.ActiveSketch Is Nothing Then
        If False = model.SketchManager.ActiveSketch.Is3D() Then
            Err.Raise vbError, "", "Only 3D sketch is supported as a target sketch"
        End If
    End If
    Dim vSketchSegs As Variant
    vSketchSegs = GetSelectedSketchSegments(model)
    If model.SketchManager.ActiveSketch Is Nothing Then
        model.ClearSelection2 True
        model.SketchManager.Insert3DSketch True
    End If
    If model.Extension.MultiSelect2(vSketchSegs, False, Nothing) = UBound(vSketchSegs) + 1 Then
        model.SketchManager.SketchUseEdge3 False, False
        model.SketchManager.Insert3DSketch True
        Err.Raise vbError, "", "Failed to select sketches"
    End If
End Sub

Function GetSelectedSketchSegments(model As SldWorks.ModelDoc2) As Variant
    Dim swSketchSegs() As SldWorks.SketchSegment
    Dim isInit As Boolean
    isInit = False
    Dim swSelMgr As SldWorks.SelectionMgr
    Set swSelMgr = model.SelectionManager
    Dim i As Integer
    For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
        If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelSKETCHES Then
            Dim swFeat As SldWorks.Feature
            Set swFeat = swSelMgr.GetSelectedObject6(i, -1)
            Dim swSketch As SldWorks.sketch
            Set swSketch = swFeat.GetSpecificFeature2
            Dim vSegs As Variant
            vSegs = swSketch.GetSketchSegments
            Dim j As Integer
            If Not IsEmpty(vSegs) Then
                For j = 0 To UBound(vSegs)
                    If Not isInit Then
                        ReDim swSketchSegs(0)
                        isInit = True
                        ReDim Preserve swSketchSegs(UBound(swSketchSegs) + 1)
                    End If
                    Set swSketchSegs(UBound(swSketchSegs)) = vSegs(j)
            End If
        End If
    GetSelectedSketchSegments = swSketchSegs
End Function