Excel VBA to import Block names from Autocad

[rcb007]

I am having a hard time trying to get selected blocks from AutoCAD into excel. I am wanting it to write each block by name on each row that is selected. The routine does work, which will interface with Autocad to allow me to select the blocks, but as for take the selection and writing the number of selected blocks in excel. Any ideas?

 

Sub PickBlocksAndGetData()
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range

'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim Block As AcadBlock

' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant

'for general variables managing purposes
Dim iRow As Long
Dim BlockName As Double

' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
     

' selecting Blocks on screen by selelection set filtering method
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("BlockSSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("BlockSSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "Insert"
   
    'selecting Blocks
    ssetObj.SelectOnScreen gpCode, dataValue

' processing Blocks

    If ssetObj.Count > 0 Then
   
        ' writing sheet headings
        Set MySht = ActiveSheet
        Set MyCell = MySht.Cells(1, 1)
        With MyCell
            .Offset(0, 0).Value = "Block Name"
        End With
       
        'clearing previous written data
        iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
        If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
       
        'retrieving Block Name and writing them on worksheet
        iRow = 1
        For Each Block In ssetObj
            'retrieving Block Name
            With Block
                BlockName = .Name
            End With
           
            ' writing Block Name
            With MyCell
                .Offset(iRow, 0).Value = "Block Name" & iRow
            End With
            iRow = iRow + 1
        Next Block
       
    End If

' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing

End Sub

 

Thank you for any help!

Edited October 18, 2022 by rcb007

[BIGAL]

As your running a excel macro did you google for help it should be out there maybe not 100% but a start.

 

Do you have to run in excel as Autocad can open and populate excel direct, like your code.

 

For me VBA or LIsp make a selection set, sort by block name, count block names into a new list, run make rows of the list. That is a few things missing in your code. Need to make a array in VBA maybe.

 

There is heaps of "count blocks to CSV lisp or vba" Google.

https://myengineeringworld.net/2014/02/count-blocks-autocad-vba.html#:~:text=How to use it 1 Open AutoCAD. 2,will appear (see the figure above). More items
 

[rcb007]

Thanks for the guidance BIGAL, I have an excel worksheet which I want to import the selected blocks. Then the worksheet counts and sort by the block names to generate the results I need. I have played around with some that are lisp driven, like Blocks2Excel, but with that setup it creates a new csv. 

[BIGAL]

I have stopped doing import csv and do direct to excel. There is a program getexcel.lsp which is a great place to start, which is what I did adding/changing a few functions. the latest is select rows of text and they appear as rows in excel. There is lots of code examples by Fixo unfortunately he is no longer with us. 

 

Just a comment i have gone deeper with counting blocks with up to 5 attributes deep used in determining common blocks the blocks can have 0 or tested on blocks with 20 attributes a mixture of blocks. Reult goes to a table but then I have read table export to excel also.

 

 

[rcb007]

Thank you for sharing. I was able to make alittle progress. I have stumbled on this code below from here.

https://forums.autodesk.com/t5/vba/extract-attributes-by-specific-block-name/td-p/9047161

 

Option Explicit
Sub Extract()
'for Autocad application managing purposes
    Dim ACAD As AcadApplication
    Dim ThisDrawing As AcadDocument
    Dim Block As AcadBlock
    Dim MySelection As AcadSelectionSet

' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument

   If ThisDrawing Is Nothing Then
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If

   '-------------------------------------------------------
   'Excel setup

   Dim Excel As Application
   Dim MySheet As Excel.Worksheet
   Dim BlckNameRng As Excel.Range, TagsRng As Excel.Range, myCell As Excel.Range
   Dim iniColStr As String
   Dim iniRow As Long, iniCol As Long

   ' handling excel application
   On Error Resume Next
   Set Excel = GetObject(, "Excel.Application")
   If Err Then Set Excel = CreateObject("Excel.Application")

   ' handling workbook and worksheet
   With Excel
       .Visible = True
       Set MySheet = .ActiveWorkbook.ActiveSheet
       If Err Then
           .Workbooks.Add
           Set MySheet = .ActiveWorkbook.ActiveSheet
       End If
       On Error GoTo 0
   End With

   'handling columns where to start writing data from
   iniColStr = "A"    '<-- Here you specify which column to start writing data from
   iniRow = 1          '<-- Here you specify which row to start writing data from
   iniCol = MySheet.Range(iniColStr & "1").Column
   Set BlckNameRng = MySheet.Cells(iniRow, iniCol).Resize(, 1000) ' this will clear excel cells in 1000 columns right of the initial one
   Set TagsRng = BlckNameRng.Offset(1)
   With BlckNameRng
       .EntireColumn.Clear
       With .Font
           .Bold = True
           .Color = 1152
       End With
   End With

   '-------------------------------------------------------


   '-------------------------------------------------------
   'blocks reference searching&handling

   Dim myBlckRef As AcadBlockReference
   Dim Attrs As Variant
   Dim nBlckRefs As Integer, iBlckRef As Integer, nAttrs As Integer, iAttr As Integer, nTags As Integer
   Dim BlckName As String, BlckHandle As String

   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   Dim ssetObj As AcadSelectionSet

   Dim myRow As Long, myCol As Long
   Dim LBnd As Integer, Ubnd As Integer

    
    'selecting block references in the active drawing
    gpCode(0) = 0
    dataValue(0) = "INSERT"
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets("BlockRefSset")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("BlockRefSset")
    ssetObj.Clear
    On Error GoTo 0
        'ssetObj.Select acSelectionSetAll, , , gpCode, dataValue      'Selects All Objects within dwg automatically
        ssetObj.SelectOnScreen 'FilterType, FilterData                      'User Selects Objects within dwg

   
   'handling block references found
   nTags = 0 ' this counter will keep track of the number of columns filled with blockreferences data ("handles" and "attributes")
   nBlckRefs = ssetObj.Count
   
   
   For iBlckRef = 0 To nBlckRefs - 1
       Set myBlckRef = ssetObj.Item(iBlckRef)
       If myBlckRef.HasAttributes Then

           ' getting blockreference info
           With myBlckRef
               BlckName = .Name
               BlckHandle = .Handle
               Attrs = .GetAttributes
           End With
           LBnd = LBound(Attrs)
           Ubnd = UBound(Attrs)
           nAttrs = Ubnd - LBnd + 1

           ' handling excel list structure consequent to blockreference blockname
           Set myCell = BlckNameRng.Find(BlckName, LookIn:=xlValues) ' searching for blockname existence
           If myCell Is Nothing Then 'if the blockname hasn't already been met-> registered

               'then we have to arrange new columns to house blockreference data (handle and attributes tagstrings and textstrings)

               myCol = nTags + 1 ' setting ref column (where to start writing from) one to the right of the last one
               nTags = nTags + 1 + nAttrs ' update number of columns to be filled with data: the "1" is for the "handle" column

               ' writing block header cells
               With BlckNameRng(1, myCol)
                   .Value = BlckName
                   With .Resize(, nAttrs + 1)
                       .Merge
                       .BorderAround (xlContinuous)
                       .HorizontalAlignment = xlCenter
                   End With
               End With

               ' writing blockreference data header cells (handle and attributes tags)
               With TagsRng(1, myCol)
                   .Value = "HANDLE"
                   .BorderAround (xlContinuous) 'every block data heade is boxed
                   For iAttr = LBnd To Ubnd
                       With .Offset(0, 1 + iAttr - LBnd)
                           .Value = Attrs(iAttr).TagString
                           .BorderAround (xlContinuous)
                           .HorizontalAlignment = xlCenter
                       End With
                   Next iAttr
               End With

           Else
               ' if the blockname has already been listed
               myCol = myCell.Column - BlckNameRng.Column + 1 'set ref column to the found cell one
           End If

           'writing blockreference data cells
           With BlckNameRng.Offset(, myCol - 1).EntireColumn
               myRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row ' getting the first free cell in the column
               With .Cells(myRow, 1)
                   .Borders(xlEdgeLeft).LineStyle = xlContinuous ' left border the 1st column
                   .Value = BlckHandle ' writing handle data
                   For iAttr = LBnd To Ubnd
                       .Offset(0, 1 + iAttr - LBnd).Value = Attrs(iAttr).TextString ' writing attributes string data
                   Next iAttr
                   .Offset(0, 1 + Ubnd - LBnd).Borders(xlEdgeRight).LineStyle = xlContinuous ' right border the last column
               End With
           End With

       End If
   Next iBlckRef
   '-------------------------------------------------------
   With BlckNameRng.CurrentRegion
       .Columns.AutoFit
       .Select
   End With
   Set Excel = Nothing
End Sub

 

I have added an option to either select the blocks or automatically select all the blocks in the dwg. This only imports selected blocks with attributes only. It is extremely slow if you have ALOT (a couple hundred) of blocks compared to the blocks2excel.lsp (Which is really fast). It would be interesting to see if the lisp could actually paste it into an open workbook rather than exporting it to a new csv file every time.

Definitely getting there. Thank you for the help as always you are the man! 

 

(defun c:Blocks2Excel (/ bks int sel ent nm ds b ly f lst fl op)
;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-explode-all-dynamic-blocks-except-named-blocks/td-p/7700420
 ;;--------------------------------------------;;
 ;;						;;
 ;; Author : Tharwat 10.June.2015		;;
 ;; Modified on 3rd.Aug.2017 to allow users to	;;
 ;; select specific blocks.			;;
 ;;--------------------------------------------;;
 ;; Compute the quantity of all blocks in	;;
 ;; a drawing and write the outcome to an	;;
 ;; Excel file format in format .csv		;;
 ;;--------------------------------------------;;
 ;; Layer Name:,Block Name:,QTY,Description	;;
 ;;						;;
 ;;--------------------------------------------;;
 (princ"\nSelect blocks :")
 (if (setq bks (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
           int -1
           sel (ssget '((0 . "INSERT"))))
   (while (setq ent (ssname sel (setq int (1+ int))))
     (if (and (setq nm (vla-get-effectivename (vlax-ename->vla-object ent)))
              (setq ds (if (vlax-property-available-p (setq b (vla-item bks nm)) 'comments)
                         (vla-get-comments b)
                         "")
                    )
              (setq ly (cdr (assoc 8 (entget ent))))
              )
       (if (vl-some '(lambda (x) (and (eq ly (car x)) (eq nm (cadr x)) (setq f x))) lst)
         (setq lst (subst (list ly nm (1+ (caddr f)) ds) f lst))
         (setq lst (cons (list ly nm 1 ds) lst))
         )
       )
     )
   )      
 (setq lst (vl-sort lst '(lambda (j k) (< (car j) (car k)))))
 (cond ((not lst) (alert "Couldn't find any block in this drawing !!"))
       ((and (setq fl (getfiled "Specify new Excel file name" (getvar 'DWGPREFIX) "csv" 1))
             (setq op (open fl "w"))
             )
;;        (write-line "Layer Name:;Block Name:;QTY;Description" op)
        (write-line "Block Name:-QTY" op)
        (mapcar '(lambda (x)
;;                   (write-line (strcat (car x) ";" (cadr x) ";" (itoa (caddr x)) ";" (nth 3 x)) op))
                   (write-line (strcat (cadr x) "-" (itoa (caddr x))) op))
                lst)
        (close op)
        )
       )
 (princ)
 )(vl-load-com)

(c:Blocks2Excel)

 

Edited October 20, 2022 by rcb007

[BIGAL]

Quick answer is yes. Rather than write to a csv file you Putcell writing direct to a cell in Excel. This can be a row or column of data.

 

You have some options easiest is open a new excel and fill in. Can do open file, add to current open excel, change to correct workbook and sheet, add new sheet, plus more.

 

Again post a sample dwg and the excel result.

 

Solved: Text from selection to excel - Page 2 - Autodesk Community - AutoCAD

Edited October 20, 2022 by BIGAL

[rcb007]

Please see the attached dwg and csv. Maybe this will help. This is basic, but its 2 blocks with an attribute.

Block Test.dwg blocks test.csv

[BIGAL]

Will see what I can do bit busy at moment.