Excel VBA insert Tag block value

hello everyone

I have an excel sheet in which the columns are divided in this way

A = X axis

B = Y axis

C = Z axis

D = Block Name

E = Scale X

F = Scale Y

G = Z Scale

H = rotation angle

The button "Insert Blocks" we put blocks in the coordinates , cells (A : C )

I would like to have the possibility of incorporating the TAG block

then the column "I" becomes

I = Tag1

Code

    Dim AcadApp                 As Object
   Dim AcadDoc                 As Object
   Dim acadBlock               As Object
   Dim LastRow                 As Long
   Dim i                       As Long
   Dim insertionPoint(0 To 2)  As Double
   Dim BlockName               As String
   Dim BlockScale              As ScaleFactor
   Dim RotationAngle           As Double
   
   'Activate the coordinates sheet and find the last row.
   With Sheets("Coordinates")
       .Activate
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
       
   'Check if there are coordinates for at least one circle.
   If LastRow < 2 Then
       MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error"
       Exit Sub
   End If
   
   'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
   On Error Resume Next
   Set AcadApp = GetObject(, "AutoCAD.Application")
   If AcadApp Is Nothing Then
       Set AcadApp = CreateObject("AutoCAD.Application")
       AcadApp.Visible = True
   End If
   
   'Check (again) if there is an AutoCAD object.
   If AcadApp Is Nothing Then
       MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
       Exit Sub
   End If
   On Error GoTo 0
   
   'If there is no active drawing create a new one.
   On Error Resume Next
   Set AcadDoc = AcadApp.ActiveDocument
   If AcadDoc Is Nothing Then
       Set AcadDoc = AcadApp.Documents.Add
   End If
   On Error GoTo 0

   'Check if the active space is paper space and change it to model space.
   If AcadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
       AcadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
   End If
   
   On Error Resume Next
   'Loop through all the rows and add the corresponding blocks in AutoCAD.
   With Sheets("Coordinates")
       For i = 2 To LastRow
           'Set the block name.
           BlockName = .Range("D" & i).value
           'If the block name is not empty, insert the block.
           If BlockName <> vbNullString Then
               'Set the insertion point.
               insertionPoint(0) = .Range("A" & i).value
               insertionPoint(1) = .Range("B" & i).value
               insertionPoint(2) = .Range("C" & i).value
               'Initialize the optional parameters.
               BlockScale.X = 1
               BlockScale.Y = 1
               BlockScale.Z = 1
               RotationAngle = 0
               'Set the optional parameters (if there are values on the corresponding ranges).
               If .Range("E" & i).value <> vbNullString Then BlockScale.X = .Range("E" & i).value
               If .Range("F" & i).value <> vbNullString Then BlockScale.Y = .Range("F" & i).value
               If .Range("G" & i).value <> vbNullString Then BlockScale.Z = .Range("G" & i).value
               If .Range("H" & i).value <> vbNullString Then RotationAngle = .Range("H" & i).value
               'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle).
               'The 0.0174532925 is to convert degrees into radians.
               Set acadBlock = AcadDoc.ModelSpace.InsertBlock(insertionPoint, BlockName, _
                    BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925)
           End If
       Next i
   End With
   
   'Zoom in to the drawing area.
   AcadApp.ZoomExtents

   'Release the objects.
   Set acadBlock = Nothing
   Set AcadDoc = Nothing
   Set AcadApp = Nothing
   
   'Inform the user about the process.
   MsgBox "The blocks were successfully inserted in AutoCAD!", vbInformation, "Finished"

End Sub

how can I change the code ?

greetings gigi

Win7 - Autocad electrical 2015

This will give tag name If .Range("I" & i).value vbNullString Then RotationAngle = .Range("I" & i).value add block then update attributes using tagname.

something like If attribs(x).Tagstring = Tag1 do something you have to step through the attributes (x) checking tagnames.

thanks for the reply

I am very confused

I do not know what I have to declare events autocad

please can you post an example

This snippet should help

Dim attribs As Variant

Set SS = ThisDrawing.SelectionSets.Add("pit1sel")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
If SS.Item(Cntr).Name = BLOCK_NAME Then

  attribs = SS.Item(Cntr).GetAttributes
' need a for x loop that equals number of attributes I have not done it before maybe Cntrxmax = attribs.Count

if attribs(x).Tagstring = Tag1 then do something

Bigal thank you for help and advice

ps I saw your discussion on this topic with the same values

but I think the code is not applicable to what I'm using

it crashes all

Merry Christmas and thank you .........

Hi Blintz,

Did you complete the code?

you can contact with me about the code?

I found a similar code.code is working but for simple block.

I wanted change for attribute block but I can not do.

Can you help?

Option Explicit

'A custom type that holds the scale factors of the block.
Private Type ScaleFactor
   X As Double
   Y As Double
   Z As Double
End Type

Sub InsertBlocks()

   '--------------------------------------------------------------------------------------------------------------------------
   'Inserts blocks in AutoCAD using data - insertion point, block name/full path, scale factors, rotation angle - from Excel.
   'Note that the block name or the block path must already exists, otherwise nothing will be inserted.
   'The code uses late binding, so no reference to external AutoCAD (type) library is required.
   'It goes without saying that AutoCAD must be installed at your computer before running this code.
   
   'Written by:    Christos Samaras
   'Date:          21/04/2014
   'e-mail:        xristos.samaras@gmail.com
   'site:          http://www.myengineeringworld.net
   '--------------------------------------------------------------------------------------------------------------------------
                
        ' Define the block

   'Declaring the necessary variables.
   Dim acadApp                 As Object
   Dim height                  As Double
   Dim acadDoc                 As Object
   Dim acadBlock               As Object
   Dim attributeObj            As Object
   Dim LastRow                 As Long
   Dim i                       As Long
   Dim InsertionPoint(0 To 2)  As Double
   Dim BlockName               As String
   Dim BlockScale              As ScaleFactor
   Dim RotationAngle           As Double
   Dim tag                     As String
   Dim value                   As String
   Dim prompt                  As String
   tag = "ATT1"
   value = Range("E3")
   height = 250

   
   'Activate the coordinates sheet and find the last row.
   With Sheets("Coordinates")
       .Activate
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
       
   'Check if there are coordinates for at least one circle.
   If LastRow < 2 Then
       MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error"
       Exit Sub
   End If
   
   'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
   On Error Resume Next
   Set acadApp = GetObject(, "AutoCAD.Application")
   If acadApp Is Nothing Then
       Set acadApp = CreateObject("AutoCAD.Application")
       acadApp.Visible = True
   End If
   
   'Check (again) if there is an AutoCAD object.
   If acadApp Is Nothing Then
       MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
       Exit Sub
   End If
   On Error GoTo 0
   
   'If there is no active drawing create a new one.
   On Error Resume Next
   Set acadDoc = acadApp.ActiveDocument
   If acadDoc Is Nothing Then
       Set acadDoc = acadApp.Documents.Add
   End If
   On Error GoTo 0

   'Check if the active space is paper space and change it to model space.
   If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
       acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
   End If
   
   On Error Resume Next
   'Loop through all the rows and add the corresponding blocks in AutoCAD.
   With Sheets("Coordinates")
       For i = 2 To LastRow
       
       
           'Set the block name.
           BlockName = .Range("D" & i).value
           'If the block name is not empty, insert the block.
           If BlockName <> vbNullString Then
               'Set the insertion point.
               InsertionPoint(0) = .Range("A" & i).value
               InsertionPoint(1) = .Range("B" & i).value
               InsertionPoint(2) = .Range("C" & i).value
             
             
               'Initialize the optional parameters.
               BlockScale.X = 1
               BlockScale.Y = 1
               BlockScale.Z = 1
               RotationAngle = 0
         
                       
               'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle).
               'The 0.0174532925 is to convert degrees into radians.
               
                               
               Set attributeObj = acadBlock.AddAttribute(height, _
                         prompt, InsertionPoint, tag, value)
                         
               Set acadBlock = acadDoc.ModelSpace.Insertblock(InsertionPoint, BlockName, _
                               BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925)
                               
           End If
       Next i
   End With

   'Zoom in to the drawing area.
   acadApp.ZoomExtents

   'Release the objects.
   Set acadBlock = Nothing
   Set acadDoc = Nothing
   Set acadApp = Nothing
   
End Sub