Sub ShapeToFile()
    Dim sh As Worksheet, S As String, n&
    Dim shp As Shape, gp As BSGraphic
    
    Set sh = Sheets("DATA")
    
    Set gp = New BSGraphic
    
    n = 0
    For Each shp In sh.Shapes
        n = n + 1
        shp.CopyPicture xlScreen, xlBitmap
        'Set lm = BSImageList1.ListImages.AddFromClipboard(CF_BITMAP)
        gp.LoadFromClipboard CF_BITMAP
        'lm.SaveToFile "C:\Users\ADMIN\Desktop\shape\" & "pic " & n & ".bmp"
        gp.SaveToFile "C:\Users\ADMIN\Desktop\shape\" & "pic " & n & ".bmp"
        
    Next
    Set gp = Nothing
End Sub