How to change the attribute value of an existing block using VBA?

[shuaib_cad]

I want to change the attribute value (tag name: DRAWINGNUMBER) in a block (block name: (BLOCK01).

Please help me with the VBA code.

Regards,

Mohammed Shuaib

[grobnik]

Hi @shuaib_cad :

Here a previous post to modify attributes by Excel, but the main scope it's the same:

https://forums.autodesk.com/t5/vba/get-value-block-attributes-from-autocad-into-excel-with-vba/td-p/...

Bye

[shuaib_cad]

That's a different topic altogether. I want the attribute value to be changed to a new value using VBA.

Please help me with a simple code.

Regards,

Mohammed Shuaib

[grobnik]

Hi @shuaib_cad , look inside the code it's applicable to your request, however here the code:

Sub AttrChange()
For Each ENTITY In ThisDrawing.ModelSpace                                                   '  For each entity inside modele space
    If ENTITY.ObjectName = "AcDbBlockReference" Then                                        ' 
        If ENTITY.EffectiveName = "BLOCK01" Then  ' check block name inside the dwg
            If ENTITY.HasAttributes = True Then                                             ' If block has attributes
                ATTRIB_LIST = ENTITY.GetAttributes                                          ' GET THE ARRAY "ATTRIB_LIST" 
For MyTAG=Lbound(ATTRIB_LIST) to Ubound(ATTRIB_LIST)
 if MyTAG.TAGSTRING="DRAWINGNUMBER" then
   MyTAG.TEXTSTRING="NEW VALUE"
 end if
Next
end if
end if
Next
End sub

I have some issue with Autocad now and I cannot test in deep, try above code and let us know.

Check the ATTRIB_LIST Array, if you know exactly the position of TAG DRAWINGNUMBER [ATTRIB_LIST (???).TAGSTRING] inside the array, you can change directly the wanted TAG with ATTRIB_LIST (???).TEXTSTRING="NEW VALUE". in this way you can avoid the for next loop see:

For MyTAG=Lbound(ATTRIB_LIST) to Ubound(ATTRIB_LIST)
if MyTAG.TAGSTRING="DRAWINGNUMBER" then
MyTAG.TEXTSTRING="NEW VALUE"
end if
Next

[shuaib_cad]

Hi Grobnik!

It isn't working for me. I have no idea about the array that you mentioned.

My requirement is very simple. I have a drawing with the below details:-

Block name: BLOCK01

Attribute tag name: DRAWINGNUMBER

Existing attribute value: XXXXX

New attribute value needed: 12345

Regards,

Mohammed Shuaib

[grobnik]

Hi @shuaib_cad ,

did you able to use VBA ? did you test the code ? step by step ?

Whenever you reach the row code:

ATTRIB_LIST = ENTITY.GetAttributes

the variable ATTRIB_LIST will contain all block attributes, as an array.

Debug such variable, if you will have only one attribute, and if you want to change you have to write:

ATTRIB_LIST(0).TEXTSTRING="12345".

But in order to do the changes you have to be able to catch the block with above code.

[JBerns]

@shuaib_cad,

If I understand the example given by @grobnik, it was intended to show how VBA goes

through the modelspace of the current drawing looking for inserts (blockrefreences)

If the code finds a block named BLOCKO1, then get the attributes and store them in a VBA array.

Whether the block has 1 or several attributes, retrieving to a VBA array is normal.

Now, loop through the array until you find a match for the attribute tag you want to change.

Once the tag is found, the new value is replaced with the old value.

The code is missing an "END IF" statement before the last "Next" statement.

I have not been able to run the code yet myself. I get an error related to MyTAG.

I think because it was not declared (missing a DIM statement).

Is it necessary to perform this drawing edit with VBA? I don't know your programming experience. Perhaps another language, such as AutoLISP could prove simpler as you requested.

Do you want to replace this value in a single block, a selection of blocks, or all blocks within a drawing?

I hope this is helpful. We look forward to your reply.

Regards,

Jerry

[grobnik]

Yes, it's true, me too I have some trouble with AutoCAD now, so I'm not able
to test.

But
@shuaib_cad, he says that the block has only one attribute, so the for next
cycle could be deleted and attempting to reach directly the attribute with
value as explained.

[grobnik · Accepted solution]

@shuaib_cad @JBerns 

here the correct code, sorry I had some trouble with Autocad.

Sub AttrChange()
For Each ENTITY In ThisDrawing.ModelSpace                                                   '  For each entity inside modele space
    If ENTITY.ObjectName = "AcDbBlockReference" Then                                        '
        If ENTITY.EffectiveName = "BLOCK01" Then  ' check block name inside the dwg
            If ENTITY.HasAttributes = True Then                                             ' If block has attributes
                ATTRIB_LIST = ENTITY.GetAttributes                                          ' GET THE ARRAY "ATTRIB_LIST"
                For MyTAG = LBound(ATTRIB_LIST) To UBound(ATTRIB_LIST)
                    If ATTRIB_LIST(MyTAG).TagString = "DRAWINGNUMBER" Then
                        ATTRIB_LIST(MyTAG).TextString = "12345"
                    End If
                Next
            End If
        End If
    End If
Next
End Sub

Let us know, please check the Attribute TAG Name if it's really DRAWINGNUMBER.

[JBerns]

@grobnik,

The code works great! Well done. 

Regards,

Jerry

[trae.beall]

In this example, is it also possible to edit the TagString?

[Ed__Jobe]

---

@trae.beall wrote:

In this example, is it also possible to edit the TagString?

---

That's what line 8 does in the example in post 8.

[trae.beall]

Hmm...seems like line 8 is a conditional. However, I think I've figure out my own question, but have a follow-up.....
Can an update to the TagString be done without opening the file? I believe I am able to read Attributes of a CAD Block with the file open in code, but not on my display.

[Ed__Jobe]

Yes, it's a condition of an If statement, but it should show you the syntax for editing it. For example:

If ATTRIB_LIST(MyTAG).TagString = "DRAWINGNUMBER" Then
   ATTRIB_LIST(MyTAG).TagString = "NEWTAG"
End If

Yes, you can edit a drawing database without opening in in the editor. You are still opening it though. Search this forum for ObjectDbx. You need to create an AxDbDocument.

[trae.beall]

hmm...seems like there would be some sort of .Update and .Save. My follow-up question was about the best way to do this and if the file could be Open in code but closed on display.

[Ed__Jobe]

---

@trae.beall wrote:

hmm...seems like there would be some sort of .Update and .Save. My follow-up question was about the best way to do this and if the file could be Open in code but closed on display.

---

Did you read this part?

"Yes, you can edit a drawing database without opening in in the editor. You are still opening it though. Search this forum for ObjectDbx. You need to create an AxDbDocument." For example, here is a snippet from an import routine:

    'return a valid filename
    If Not strFilePath = vbNullString Then
        SaveSetting strAppName, strRegPath, "DefaultFile", strFilePath
        'get a PlotConfiguration name from the file
        Set oDbx = ThisDrawing.Application.GetInterfaceObject("objectdbx.axdbdocument.24")
        oDbx.xOpen strFilePath
        Set oDbxDoc = oDbx.Doc
        
            'separate ms and ps PlotConfigurations
            Set colPCs = oDbxDoc.PlotConfigurations
            For Each objPC In colPCs
                If objPC.ModelType = True Then
                    colMsPcs.Add objPC, objPC.Name
                Else
                    colPsPcs.Add objPC, objPC.Name
                End If
            Next objPC

[trae.beall]

I believe I am creating the AxDbDocument, but I cannot seem to Save when changing a TagString. I've also tried dwg.Update with dwg.Save, but it didn't work.

With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> 0 Then
            OnStart
            For Each File In .SelectedItems
                If LCase(Right(File, 3)) = "dwg" Then
                    curRow = curRow + 1

                    Cells(curRow, 1).Value = Mid(File, InStrRev(File, "\") + 1)
                    Cells(curRow, 1).Font.Bold = True
                    
                    Set dwg = acad.GetInterFaceObject("ObjectDBX.AxDbDocument.24")
                    dwg.Open File
                    
                    Set pspace = dwg.PaperSpace
                    Set mspace = dwg.ModelSpace
                    
                    Dim flag As Integer
                    flag = 0
                    
                    Dim title As String
                    title = ""
                    
                    'Loop through each element in paperspace
                    For Each elem In pspace
                        With elem
                            'Check if a block has been found and if it has attributes
                            If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                                If .HasAttributes <> 0 And elem.Name = "SMECOborderSUB" Then
                                    'MsgBox elem.Name
                                    flag = 1
                                    blkAttributes = .GetAttributes
                                    
                                    'Loop through each attribute of the block
                                    For i = LBound(blkAttributes) To UBound(blkAttributes)
                                        'MyStr = blkAttributes(i).TagString
                                        'MsgBox MyStr
                                        If StrComp(blkAttributes(i).EntityName, "AcDbAttribute", 1) = 0 Then
                                            'Check if a column has already been created for the tag
                                            If Not dictAttr.Exists(blkAttributes(i).TagString) Then
                                                dictAttr.Add blkAttributes(i).TagString, curCol
                                                Cells(4, curCol).Value = blkAttributes(i).TagString
                                                Cells(4, curCol).Font.Bold = True
                                                curCol = curCol + 1
                                            Else
                                            'If the column has already been created then let's index it
                                                MyStr = blkAttributes(i).TagString & n
                                                blkAttributes(i).TagString = MyStr
                                                blkAttributes(i).Update
                                                dictAttr.Add MyStr, curCol
                                                Cells(4, curCol).Value = MyStr
                                                Cells(4, curCol).Font.Bold = True
                                                curCol = curCol + 1
                                                n = n + 1
                                            End If
                                            
                                            'Select Case blkAttributes(i).TagString
                                            '    Case "2-", "3-", "4-", "5-"
                                            '        title = title & blkAttributes(i).TextString & " "
                                            'End Select
                                            
                                            'Add value of tag
                                            Cells(curRow, dictAttr(blkAttributes(i).TagString)).NumberFormat = "@"
                                            Cells(curRow, dictAttr(blkAttributes(i).TagString)).Value = blkAttributes(i).TextString
                                        End If
                                    Next i
                                    'curRow = curRow + 1
                                    Exit For
                                End If
                            Else
                                'MyStr = elem.EntityName
                                'MsgBox MyStr
                                'Cells(curRow, 1).Value = elem.EntityName
                                'curRow = curRow + 1
                            End If
                        End With
                    Next elem
                    
                    'check model space
                    'really should just create a function instead of copy/pasting it twice
                    If flag = 0 Then
                        For Each elem In mspace
                            With elem
                                'Check if a block has been found and if it has attributes
                                If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                                    If .HasAttributes And InStr(.Name, "CEII") <> 0 Then
                                        flag = 1
                                        blkAttributes = .GetAttributes
                                        
                                        'Loop through each attribute of the block
                                        For i = LBound(blkAttributes) To UBound(blkAttributes)
                                            If StrComp(blkAttributes(i).EntityName, "AcDbAttribute", 1) = 0 Then
                                                'Check if a column has already been created for the tag
                                                If Not dictAttr.Exists(blkAttributes(i).TagString) Then
                                                    dictAttr.Add blkAttributes(i).TagString, curCol
                                                    Cells(4, curCol).Value = blkAttributes(i).TagString
                                                    Cells(4, curCol).Font.Bold = True
                                                    curCol = curCol + 1
                                                End If
                                                
                                                Select Case blkAttributes(i).TagString
                                                    Case "2-", "3-", "4-", "5-"
                                                        title = title & blkAttributes(i).TextString & " "
                                                End Select
                                                
                                                'Add value of tag
                                                Cells(curRow, dictAttr(blkAttributes(i).TagString)).Value = blkAttributes(i).TextString
                                            End If
                                        Next i
                                        Exit For
                                    End If
                                End If
                            End With
                        Next elem
                    End If
                    
                    'If Not dictAttr.Exists("FULL TITLE") Then
                    '    dictAttr.Add "FULL TITLE", curCol
                    '    Cells(4, curCol).Value = "FULL TITLE"
                    '    Cells(4, curCol).Font.Bold = True
                    '    curCol = curCol + 1
                    'End If
                    
                    'Cells(curRow, dictAttr("FULL TITLE")).Value = RTrim(title)
                    
                    If flag = 0 Then
                        MsgBox ("Could not find title block in drawing " & File)
                        curRow = curRow - 1
                    End If
                    
                End If
            Next File
        End If
    End With

[Ed__Jobe]

ObjectDbx has always had a bug with the Save method. It doesn't work. You have to use the SaveAs method with the same filename. Also, I don't know what version of AutoCAD you're using, but when you create the doc, you have to specify the correct class id for your version. 24 is for 2023, what I have installed.

[trae.beall]

Bingo....

MyStr = blkAttributes(i).TagString & n
blkAttributes(i).TagString = MyStr
blkAttributes(i).Update
dwg.SaveAs File
dictAttr.Add MyStr, curCol
Cells(4, curCol).Value = MyStr
Cells(4, curCol).Font.Bold = True
curCol = curCol + 1
n = n + 1

Thank you!