Remove all items from the layer in SOLIDWORKS model

Edit ArticleEdit Article
More 'Goodies'


This VBA macro collects and removes all items on the specified layer (annotations, sketch segments, blocks, sketch points and hatch). Layer itself is not removed.

Set the name of the layer in LAYER_NAME constant.

Const LAYER_NAME As String = "MY LAYER"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    Dim swLayerMgr As SldWorks.LayerMgr
    Set swLayerMgr = swModel.GetLayerManager
    Dim swLayer As SldWorks.layer
    Set swLayer = swLayerMgr.GetLayer(LAYER_NAME)
    Dim swLayerItems() As Object
    AddItems swLayer, swLayerItemsOption_Annotations, swLayerItems
    AddItems swLayer, swLayerItemsOption_SketchBlockInstance, swLayerItems
    AddItems swLayer, swLayerItemsOption_SketchHatch, swLayerItems
    AddItems swLayer, swLayerItemsOption_SketchPoint, swLayerItems
    AddItems swLayer, swLayerItemsOption_SketchSegments, swLayerItems
    If swModel.Extension.MultiSelect(swLayerItems, False, Nothing) = UBound(swLayerItems) + 1 Then
        If False = swModel.Extension.DeleteSelection2(swDeleteSelectionOptions_e.swDelete_Absorbed) Then
            Err.Raise vbError, "", "Failed to delete entities"
        End If
        Err.Raise vbError, "", "Failed to select items on layer"
    End If
End Sub

Sub AddItems(layer As SldWorks.layer, itemsType As swLayerItemsOption_e, ByRef layerItems() As Object)
    Dim vItems As Variant
    vItems = layer.GetItems(itemsType)
    If Not IsEmpty(vItems) Then

        If (Not layerItems) = -1 Then
            ReDim layerItems(UBound(vItems))
            ReDim Preserve layerItems(UBound(layerItems) + UBound(vItems) + 1)
        End If
        Dim i As Integer
        For i = 0 To UBound(vItems)
            Set layerItems(UBound(layerItems) - i) = vItems(i)
    End If
End Sub

Product of Xarial Product of Xarial