Jump to content

Recommended Posts

Posted

Good day, I am trying to make a table with legends (actual geometry). i have a code that can already create the table, populates the 1st column with block name, 2nd column layer names and 3rd column as count.. i want to convert the block names into real geometry or block shapes (like the TINSERT on a table cell).. thanks in advance.. here's my current code in autocad VBA.. Sub CountBlo1cksAndCreateTable()
    Dim acadDoc As Object
    Dim acadApp As Object
    Dim ss As Object
    Dim ent As Object
    Dim blkRef As Object
    Dim tbl As Object
    Dim pt As Variant
    Dim i As Integer
    Dim blkName As Variant
    Dim layerName As String
    Dim blkCounts As Object
    Dim blkLayers As Object
    Dim row As Integer
    Dim col As Integer
    
    ' Initialize AutoCAD
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    
    ' Create dictionaries for block counts and layers
    Set blkCounts = CreateObject("Scripting.Dictionary")
    Set blkLayers = CreateObject("Scripting.Dictionary")
    
    ' Ask user to select objects
    On Error Resume Next
    Set ss = acadDoc.SelectionSets.Add("BlockSelection")
    If Err.number <> 0 Then
        Err.Clear
        Set ss = acadDoc.SelectionSets.Item("BlockSelection")
        ss.Clear
    End If
    On Error GoTo 0
    
    ss.SelectOnScreen
    
    ' Loop through selected objects
    For i = 0 To ss.Count - 1
        Set ent = ss.Item(i)
        
        ' Check if entity is a block reference
        If ent.ObjectName = "AcDbBlockReference" Then
            Set blkRef = ent
            blkName = blkRef.Name
            layerName = blkRef.layer
            
            ' Update block count dictionary
            If blkCounts.Exists(blkName) Then
                blkCounts(blkName) = blkCounts(blkName) + 1
            Else
                blkCounts.Add blkName, 1
                blkLayers.Add blkName, layerName ' Store layer name
            End If
        End If
    Next i
    
    ' Ask user for table insertion point
    pt = acadDoc.Utility.GetPoint(, "Select table insertion point: ") ' Let user pick insertion point
    
    ' Create table with dynamic row count
    Set tbl = acadDoc.modelSpace.AddTable(pt, blkCounts.Count + 2, 3, 10, 50)
    
    ' Set individual column widths
    tbl.SetColumnWidth 0, 3000 ' Block Name column
    tbl.SetColumnWidth 1, 2000 ' Layer Name column
    tbl.SetColumnWidth 2, 1000 ' Count column
    ' Set main header
    tbl.SetText 0, 0, "BLOCK COUNT"
    
    ' Set subheaders
    tbl.SetText 1, 0, "Block Preview"
    tbl.SetText 1, 1, "Layer"
    tbl.SetText 1, 2, "Count"
    
    ' Populate table with block data starting from row 2
    row = 2
    For Each blkName In blkCounts.Keys ' blkName must be a Variant
        tbl.SetText row, 0, blkName
        tbl.SetText row, 1, blkLayers(blkName)
        tbl.SetText row, 2, blkCounts(blkName)
        row = row + 1
    Next blkName
    
    ' Clean up selection set
    ss.Clear
    acadDoc.SelectionSets.Item("BlockSelection").Delete
    
End Sub

Posted

Sorry I don’t have VBA installed, but from the docs:

 

Use SetBlockTableRecordId to add a block to a cell

 

If you want text and a block in the same cell , you’ll have to add an additional content

 

CreateContent(nRow, nCol, nIndex)
SetBlockTableRecordId2 nRow, nCol, nContent, blkId, autoFit         

           

nContent would be used like an array index

Posted

Another example code.

 

(setq blks (vla-get-blocks  (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq obj (vlax-ename->vla-object (car (entsel "\nPick object "))))
(vla-SetBlockTableRecordId Obj 2 2 (vla-get-objectid  (vla-item blks "90LD")) :vlax-true)

image.png.70ea23f12eab3baa03e88967822d4ea1.png

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...