automatic completion of tables using vba in autocad

[victorctti]

hello

Hello, I need to develop a code in VBA that can get information from two blocks, the first is just your name and the second is your name and dimensions, this data will be placed in a table within the drawing itself, and an extra column counting the lines to all of them are numbered, this is the function I want to create a table to count holes in the structure, so there would be several blocks, one for the hole and the other for the beam nomenclature, so I would need to select two blocks, fill in the table, select two more and so on . I have knowledge of VBA but this is my first time working with VBA in Autocad and I'm having some difficulties

[grobnik]

Hi,
managing large number of columns and rows table in Autocad drawing by VBA takes a lot of execution time for the processor, however if you can share a sample drawing I can show you how to select blocks and populate the table, if this is your final scope.
Basically solution could be find all blocks in the drawing, catch the count and some others info and transfer data retrived from blocks in a table for each block found in the drawing.
So in order to suggest you a best solution could be work on code using a simple drawing with some blocks and table structure created.
Bye

[grobnik · Accepted solution]

Here an example

Sub find_populate()
Dim MyBlock As Object
Dim MyTable As AcadTable
Dim CountB_A As Integer
Dim CountB_B As Integer
Dim CountB_C As Integer

 CountB_A = 0
 CountB_B = 0
 CountB_C = 0

    For Each MyBlock In ThisDrawing.ModelSpace
        If TypeOf MyBlock Is AcadBlockReference Then
            If MyBlock.Name = "BLOCK_A" Then
                CountB_A = CountB_A + 1
            End If
            If MyBlock.Name = "BLOCK_B" Then
                CountB_B = CountB_B + 1
            End If
            If MyBlock.Name = "BLOCK_C" Then
                CountB_C = CountB_C + 1
            End If
        End If
    Next
    For Each MyBlock In ThisDrawing.ModelSpace
        If TypeOf MyBlock Is AcadTable Then
           Set MyTable = MyBlock
            Exit For
        End If
    Next
           MyTable.SetCellValue 1, 0, "BLOCK_A"
           MyTable.SetCellValue 2, 0, "BLOCK_B"
           MyTable.SetCellValue 3, 0, "BLOCK_C"
           
           MyTable.SetCellValue 1, 1, CountB_A
           MyTable.SetCellValue 2, 1, CountB_B
           MyTable.SetCellValue 3, 1, CountB_C

End Sub

[jahankhan2015]

 yeah here is a picture i want to change the above object dimension from excel sheet ?

[grobnik]

Hi,

sorry but I don't understand well, in your previus post you want to fill a table from block information, now you are asking to change object dimensions from excel.... ??

If you explain what do you need we can try to suggest you a way if this is possibile by VByA.

Share the DWG could be best for test.

Bye

[victorctti]

Sub TabCol()

Dim FilterType(0 To 1) As Integer
Dim FilterData(0 To 1) As Variant
Dim FlagTCdAnt As Boolean

Dim ModelSpecObj As AcadModelSpace
Dim NCirc As Integer
Dim NCol As Integer, NLin As Integer
Dim NOrig As Integer
Dim NumLinsTCd As Variant
Dim PtoInsTCd As Variant
Dim PtoLL As Variant, PtoUR As Variant
Dim PtoMR(0 To 2) As Double
Dim SelEnt As AcadSelectionSet
Dim TabEnt As AcadTable
Dim TCCdEnt As AcadTable
Dim Verde As AcadAcCmColor
Dim Dad() As String
Dim TagShf As String
Dim LrgShf As Single
Dim PrfShf As Single

'GetEsc Esc
'check if there are no crossings
For Each SSet In ThisDrawing.SelectionSets
    If SSet.Name = "ENTS" Then
        ThisDrawing.SelectionSets.Item("ENTS").Delete ' preciso trocar o nome ents
        Exit For
    End If
Next SSet
'creat crossings
Set SelEnt = ThisDrawing.SelectionSets.Add("ENTS")

'check the block
Set BlkCol = ThisDrawing.Blocks

'filter the type of block
FilterType(0) = 0
FilterData(0) = "Insert"
FilterType(1) = 8 ' vai precisar acrescentar desenhos 3d
FilterData(1) = "SHF" ' preciso trocar o shf

SelEnt.SelectOnScreen FilterType, FilterData

'MAKES ANALYSIS AND DEFINITIONS ABOUT THE OBJECTS THAT PASS THROUGH THE FILTER
For Each BlkEnt In SelEnt 'preciso trocar nome do for
    If Left(BlkEnt.Name, 5) = "HD§SH" Then ' n sei exatamente o q é mas sh preciso trocar
    NumCarTagShf = Len(BlkEnt.Name)
    TagShf = Right(BlkEnt.Name, NumCarTagShf - 3)
    Set BlkDef = BlkCol.Item(BlkEnt.Name)
    NumEntsShf = BlkDef.Count
    
''DEFINE THE STARTING POINT OF TABLE INSERTION
    PtInsShf = BlkEnt.InsertionPoint
    AngTab = BlkEnt.Rotation
    XSFac = BlkEnt.XScaleFactor
    

'' EXTRACT DIMENSIONS FROM THE DRAWING
    AtribColShf = BlkEnt.GetAttributes
    For Each Atrib In AtribColShf
        Select Case Atrib.TagString
        Case "LARG"
            LrgShf = Atrib.TextString
        Case "PROF"
            PrfShf = Atrib.TextString ' talvez precise criar mais uma variavel para pegar o comprimento
        End Select
    Next Atrib
    
    ReDim Dad(1 To NumEntsShf, 1 To 2) As String
    
    'CYCLES THE ENTITIES IN THE BLOCK, AND STORES THE COLUMN TAGS, THEIR 'DIAMETER AND THE
     'NUM OF COLUMNS PRESENT IN SHAFT
    NumColShf = 0
    For NEnt = 0 To NumEntsShf - 1
        Set EntBlkCol = BlkDef.Item(NEnt)
        If EntBlkCol.ObjectName = "AcDbBlockReference" Then
            If Left(EntBlkCol.Name, 6) = "HD§COL" Then
                NumColShf = NumColShf + 1
                AtribColCol = EntBlkCol.GetAttributes
                For Each AtribCol In AtribColCol
                    Select Case AtribCol.TagString
                    Case "TAG"
                        Dad(NumColShf, 1) = AtribCol.TextString
                    Case "DIA"
                        Dad(NumColShf, 2) = AtribCol.TextString
                    End Select
                Next AtribCol
            End If
        End If
    Next NEnt

    'CALCULATES INSERTION POINT OF COLUMN DATA TABLE
    HTab = (NumColsShf * 4 + 5) * Esc ' preciso redimencionar tudo isso para o meu objetivo
    DistP1 = Sqr((LrgShf / 2) ^ 2 + PrfShf ^ 2)
    AngP1 = Atn(PrfShf / LrgShf * 2)
    XInsTab = LrgShf / 2 - HTab / 2
    YInsTab = PrfShf * SFac + 10 * Esc
    DistPtTab = Sqr(XInsTab ^ 2 + YInsTab ^ 2)
    AngPtTab = Atn(YInsTab / XInsTab) + Pi
    
'CALCULATE THE INSERTION POINT OF THE DATA TABLE OF COLUMNS AND EXTERNAL POINTS OF THE LINE
     'CALL
    PtTab = ThisDrawing.Utility.PolarPoint(PtInsShf, AngPtTab + AngTab, DistPtTab)
    PtP1 = ThisDrawing.Utility.PolarPoint(PtInsShf, AngP1 + AngTab, DistP1)
    PtP2 = ThisDrawing.Utility.PolarPoint(PtTab, AngTab, HTab / 2)
    
 
   'CALL PROCEDURE TO DRAW, FORMAT, SCALE AND ROTATE THE DATA TABLE 'OF COLUMNS AND DRAW LEADER LINE
    If XSFac = -1 Then
        CorAng = Pi
    Else
        CorAng = 0
    End If
    
    DesTCol PtTab, AngTab + CorAng + Pi / 2, Val(NumColShf), TagShf, Dad
    Set LineObj = ThisDrawing.ModelSpace.AddLine(PtP1, PtP2)
    LineObj.Layer = "TABCOL"
    End If
Next BlkEnt

'delet selection set
ThisDrawing.SelectionSets.Item("ENTS").Delete

End Sub

'THIS PART DRAWS THE SHAFTS TABLE
Sub DesTCol(PtInsTC As Variant, AngTC, NumCols As Integer, TagShf, Dad() As String)
Dim NCol As Integer, NLin As Integer
Dim TColsEnt As AcadTable

'FORMATTING VARIABLES
Set Verd = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") ' talvez trocar as cores
Set Cyan = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20")
Verd.ColorIndex = acGreen
Cyan.ColorIndex = acCyan

'CREATE A TABLE OF COLUMN DATA AT THE INFORMED INSERTION POINT
Set TColsEnt = ThisDrawing.ModelSpace.AddTable(PtInsTC, NumCols + 1, 3, 4, 10)
With TColsEnt

.AllowManualHeights = True

'CYCLE THE ARROW THE WIDTH OF THE COLUMNS
.SetColumnWidth 1, 8
.SetColumnWidth 2, 8

'MERGE AND FORMAT HEADER CELL LINES AND TEXT
.MergeCells 0, 0, 0, 2
.SetRowHeight 0, 3
.SetCellContentColor 0, 0, Verd
.SetCellTextHeight 0, 0, 2
.SetCellAlignment 0, 0, acMiddleCenter
.SetCellGridColor 0, 0, AcCellEdgeMask.acLeftMask, Cyan
.SetCellGridColor 0, 2, AcCellEdgeMask.acRightMask, Cyan
.SetCellGridColor 0, 0, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 1, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 2, AcCellEdgeMask.acBottomMask, Verd

'CYCLAE FORMATS THE CELLS OF THE OTHER LINES
For NLin = 1 To NumCols
    For NCol = 0 To 2
        .SetCellAlignment NLin, NCol, acMiddleCenter
        .SetCellTextStyle NLin, NCol, "SIMPLEX"
    Next NCol
Next NLin
    
'FORMAT AND LOWER CLOSURE OF THE TABLE
.SetCellGridColor NumCols, 0, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 1, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 2, AcCellEdgeMask.acBottomMask, Cyan

'PRENCHE CÉLULA DE CABEÇALHO
.SetText 0, 0, "SHAFT" & TagShf

'CICLA LINHAS E COLUNAS E FORMATA TEXTO DAS DEMAIS LINHAS DA TABELA
For NLin = 1 To NumCols
    .SetText NLin, 0, Dad(NLin, 1)
    .SetText NLin, 2, Dad(NLin, 2)
Next NLin
'SCALE THE TABLE AND COLUMNS AND SWITCH TO THE TABCOL LAYER
'.StyleName = "TABCOLS"
'    .ScaleEntity PtInsTC, 1 * Esc
 '   .Rotate PtInsTC, AngTC
  '  .Layer = "TABCOL"
End With

End Sub

I managed to find a rudimentary code, but due to updates to the project I need to do something similar with 3dsolid, but I'm finding little information, at the moment I'm studying it alone, but if anyone can help

[jahankhan2015]

Bro actually i am asking about the drawing of dynamic block  which i sent you the picture.

i am trying to change the dimension of this dynamic block from Microsoft excel though when i change the dimension in excel it should change the table consist in the drawing and dynamic block simultaneously.

i think it could be possible through data extraction ? or any other way.

and i have attached the drawing 

[grobnik]

@victorctti @jahankhan2015 

Hi, I made some other test and here a simple code for transfering data from block to excel.

I guess you can do the opposite too.

attlist(I).Value = MySheet.Cells(4, MyCol).Value

The core of the procedure is inside attlist = obj.GetDynamicBlockProperties function allowing you to get properties from dynamic block. Once you have properties inside an array in the same way of a standard block with attributes you can modify the specific value, modifying the .value of block properties you want to change.

If you want to modify block properties from excel please use double variable type writing the properties value.

Procesdure it's very poor of check because only a test.

As second issue if you have more than one block named "Example", you have to include the block ID before modifying the properties, in order to select specific block and not another block with the same name, but with differents properties.

Before to start procedure you have to run excel, and set the project reference adding Microsoft excel library in VBA development tools inside Autocad.

Let me know.

Sub Excel()
MyCol = 1
Set ObjExcel = GetObject(, "Excel.Application")
ObjExcel.Visible = True
Set MySheet = ObjExcel.ActiveSheet
For Each obj In ThisDrawing.ModelSpace
        If TypeOf obj Is AcadBlockReference Then
          If obj.IsDynamicBlock Then
            Set blk = obj
            If blk.EffectiveName = "example" Then
                attlist = obj.GetDynamicBlockProperties
                MySheet.Cells(1, 1).Value = blk.EffectiveName
            
                For I = LBound(attlist) To UBound(attlist)
                MySheet.Cells(2, MyCol).Value = attlist(I).PropertyName
                MySheet.Cells(3, MyCol).Value = attlist(I).Value
                MyCol = MyCol + 1

                Next
            End If
        End If
        End If
        Next
End Sub