Excel to Autocad insert Attribute Block

[witchhero]

Sample.rar

Hi friends,

I found a VBA code from the internet. Code blocks according to the positioning coordinates in AutoCAD.

code is working but for simple block.

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

 

Who can help?

 

I hope that me understand. because my english Too bad

 

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

Edited June 6, 2015 by witchhero

[witchhero]

Is there no one to answer?

[BIGAL]

Here is an example of some code updating attribute values

 

attribs = SS.Item(Cntr).GetAttributes
       
    If attribs(0).TextString = pitname Then
      pt1 = ThisDrawing.Utility.GetPoint(, " pick first point")

      txtx1 = CStr(FormatNumber(pt1(0), 3))
      TXTY1 = CStr(FormatNumber(pt1(1), 3))
       
       attribs(1).TextString = txtx1
       attribs(2).TextString = TXTY1
       
       attribs(1).Update
       attribs(2).Update

[witchhero]

Hi Bigal,

Thank you very much for the time which you spent to me.

The code is given by how I can integrate my own code? I'm not very good at coding,You can help me please?

[BIGAL]

I have stopped doing VBA it may be better to look at VLISP or plain lisp lots of examples to do the same thing.

[witchhero]

Thank you. My search continues, I hope my right

[piscopatos]

i was where you were.

first you need to be able to make a list of your attribute values in excel sheet. in your sample in the sheets("coordinates")

then you will use ;

 

Dim varAttributes As Variant

 

varAttributes = acadblock.GetAttributes

 

For L = LBound(varAttributes) To UBound(varAttributes)

varAttributes(L).TextString = devrekesici(k + 1, L + 1).Value

Next

 

the above " devrekesici" is a range that i assigned. it will be whatever you want it to be.

 

hope this helps someone.

[witchhero]

Thank you very much piscopatos, its working !!

[piscopatos]

i am glad that it worked for you. Try to get into .NET API. it is abit hard but much more powerful.

[ZhiPing]

witchhero, can u up new remade code here:), thank!

 

[ducdudl2018]

could you pls share your code?? Thankyou

[edmondsforum]

try this 

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
    Dim varAttributes As Variant
    Dim varBlockProperties As Variant
    Dim Index As Variant
    Dim prop As Variant
    Dim propatr As Variant
 
    
    '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)
                                
                varAttributes = acadBlock.GetAttributes
                varAttributes(0).TextString = .Range("E" & i).value
                varAttributes(1).TextString = .Range("F" & i).value
                varAttributes(2).TextString = .Range("G" & i).value
                varAttributes(3).TextString = .Range("H" & i).value
                varAttributes(4).TextString = .Range("I" & i).value

 
                                
            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