''https://forums.autodesk.com/t5/vba/i-want-to-export-blockcell-s-image-in-table-object/td-p/10286139
Attribute VB_Name = "blocktoimage"
Option Explicit

Public Sub GetBlocksInTable()
    
    Dim ent As AcadEntity
    Dim pt As Variant
    
    On Error Resume Next
    ThisDrawing.Utility.GetEntity ent, pt, vbCr & "Select table entity:"
    If ent Is Nothing Then Exit Sub
    
    Dim tbl As AcadTable
    If TypeOf ent Is AcadTable Then
        Set tbl = ent
        ProcessBlocksInTable tbl
    End If
    
End Sub

Private Sub ProcessBlocksInTable(table As AcadTable)
    
    Dim i As Integer
    Dim j As Integer
    
    Dim cellType As AcCellType
    
    For i = 1 To table.Rows - 1
        For j = 0 To table.Columns - 1
            cellType = table.GetCellType(i, j)
            If cellType = acBlockCell Then
                WorkOnCell table, i, j
            End If
        Next
    Next
    
End Sub

Private Sub WorkOnCell(table As AcadTable, row As Integer, column As Integer)
    
    Dim blockId As LongPtr
    Dim blkNames() As String
    Dim i As Integer
    
    blockId = table.GetBlockTableRecordId(row, column)
    
    Dim blk As AcadBlock
    For Each blk In ThisDrawing.Blocks
        If blk.ObjectID = blockId Then
            ''MsgBox "Block name: " & blk.Name
            ReDim Preserve blkNames(i)
            blkNames(i) = blk.Name
            i = i + 1
        End If
    Next
    
    If i = 0 Then
        MsgBox "No block found in table!"
        Exit Sub
    End If
    
    '' Save current view - code ommitted
    
    '' Exporting block imagaes
    ExportBlockImages blkNames
    
    '' Restore saved view - code omitted
    
End Sub

Private Sub ExportBlockImages(blkNames As Variant)
    Dim i As Integer
    Dim blkName As String
    Dim exportPath As String
    exportPath = "C:\Temp\"
    
    For i = 0 To UBound(blkNames)
        blkName = blkNames(i)
        ExportBlockImage blkName, exportPath
    Next
    
End Sub

Private Sub ExportBlockImage(blkName As String, exportPath As String)

    '' Insert block at 0,0
    Dim blkRef As AcadBlockReference
    Dim insPoint(0 To 2) As Double
    insPoint(0) = 0#: insPoint(1) = 0#: insPoint(2) = 0#
    
    Set blkRef = ThisDrawing.ModelSpace.InsertBlock(insPoint, blkName, 1#, 1#, 1#, 0#)
    blkRef.Update
    
    ZoomToBlock blkRef
    
    '' export
    DoImageExport blkRef, exportPath & blkName
    
    blkRef.Delete

End Sub

Private Sub ZoomToBlock(blk As AcadBlockReference)

    Dim minPt As Variant
    Dim maxPt As Variant
    blk.GetBoundingBox minPt, maxPt
    
    Dim minP(0 To 2) As Double
    Dim maxP(0 To 2) As Double
    
    Dim deltaH As Double
    Dim deltaW As Double
    
    deltaW = (maxPt(0) - minPt(0)) * 0.1
    deltaH = (maxPt(1) - minPt(1)) * 0.1
    
    minP(0) = minPt(0) - deltaW: minP(1) = minPt(1) - deltaH: minP(2) = minPt(2)
    maxP(0) = maxPt(0) + deltaW: maxP(1) = maxPt(1) + deltaH: maxP(2) = maxPt(2)
    
    ZoomWindow minP, maxP
    
    ThisDrawing.Utility.GetString 0, vbCr & "Exporting block """ & blk.Name & """. Press Enter to continue..."
    
End Sub

Private Sub DoImageExport(blk As AcadBlockReference, fileName As String)
    
    Dim ss As AcadSelectionSet
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets.Add("mySet")
    If Err.Number <> 0 Then
        Err.Clear
        Set ss = ThisDrawing.SelectionSets("MySet")
    End If
    
    Dim ents() As AcadEntity
    ReDim ents(0)
    Set ents(0) = blk
    ss.AddItems ents
    
    ThisDrawing.Export fileName, "bmp", ss
    
    ss.Delete
    
End Sub