VBA to Populate Table (Update)

[timleonard]

This question is an extension to that in VBA to populate access table.

I have been looking for a way to expand it to update the block attributes after modifying the TableDef but with no success.
What I am trying to do is, after populating the Attribute Table, run an update query, then send the updated TableDef back to the attributes. I am not sure how to pull it back and then loop it through in order to update the attribute blocks

I really appreciate any help that can be provided. I have been searching and working at this for days.

Sub Export_Access_Attributes() 'Written by Neopa
 
' Open database and delete old records if exist
' ---------------------------------------------
    Dim dbs As DAO.Database
    Dim dbsName As String
    Dim activeDoc As AcadDocument
    Dim DocLength As Integer
    Dim Shortlength As Integer
    Dim DwgPath As String
    Dim DwgName As String
    Dim DocName As String
    Dim data As DAO.Recordset
    Dim TableDef As String
 
    Dim Attribs  As Variant     'Defaults to Variant
    Dim Handle As String
    Dim blockName As String
    Dim tag As String
    Dim Loops As String
    Dim Address As String
    Dim Label1 As String
    Dim Label2 As String
    Dim Device_Label As String
    Dim Extended_Label As String
    Dim Qty As String
    Dim Model_Num As String
    Dim Description As String
    Dim Vendor As String
    Dim CSFM_Num As String
 
    Dim ssnew As Object
    Dim setObj As Object
    Dim setColl As AcadSelectionSets
    Dim Entity As AcadEntity
    Dim blkEntity As AcadBlockReference
    Dim i As Variant        'Defaults to Variant
 
' Strip off extension .dwg
' -------------------------------
    Set activeDoc = ThisDrawing.Application.ActiveDocument
    DocName = activeDoc.Name
    DocLength = Len(DocName)
 
    Shortlength = DocLength - 4
    DwgPath = activeDoc.Path
    DwgName = Left(DocName, Shortlength)
 
    dbsName = "Project_Drawings.mdb"
    Set dbs = DBEngine.OpenDatabase(DwgPath & "\" & dbsName)   'Path to be C:\Blocks Folder
 
' Open recordset in table
' -----------------------
 
' Determine Tables Def
' --------------------------
    TableDef = "Attribute Report1"
    Set data = dbs.OpenRecordset(TableDef, dbOpenDynaset)
 
' Clear old values from table
' ---------------------------
    dbs.Execute "DELETE * FROM [Attribute Report1]", dbFailOnError
 
' Make Selection set of Blocks
' ----------------------------
   ThisDrawing.ActiveSpace = acModelSpace
    With activeDoc
        Set setColl = .SelectionSets
        For Each setObj In .SelectionSets
            If setObj.Name = "VBA" Then
                .SelectionSets.Item("VBA").Delete
                Exit For
            End If
        Next
        Set ssnew = activeDoc.SelectionSets.Add("VBA")
    End With
    ssnew.Select acSelectionSetAll
 
' Get Attribute values
' ---------------------
    For Each Entity In ssnew
 
       If Entity.ObjectName = "AcDbBlockReference" Then
       Set blkEntity = Entity
 
       If blkEntity.HasAttributes Then
        Attribs = blkEntity.GetAttributes
 
        For i = LBound(Attribs) To UBound(Attribs)
 
            Select Case Attribs(i).TagString
 
            Case "HANDLE"
                Handle = Attribs(i).TextString
            Case "BLOCKNAME"
                blockName = Attribs(i).TextString
            Case "TAG"
                tag = Attribs(i).TextString
            Case "LOOP"
                Loops = Attribs(i).TextString
            Case "ADDRESS"
                Address = Attribs(i).TextString
            Case "LABEL1"
                Label1 = Attribs(i).TextString
            Case "LABEL2"
                Label2 = Attribs(i).TextString
            Case "DEVICE_LABEL"
                Device_Label = Attribs(i).TextString
            Case "EXTENDED_LABEL"
                Extended_Label = Attribs(i).TextString
            Case "QTY"
                Qty = Attribs(i).TextString
            Case "MODEL_NUM"
                Model_Num = Attribs(i).TextString
            Case "DESCRIPTION"
                Description = Attribs(i).TextString
            Case "VENDOR"
                Vendor = Attribs(i).TextString
            Case "CSFM_NUM"
                CSFM_Num = Attribs(i).TextString
 
            End Select
 
        Next i
 
' Fill Database Table-----------------
            If Handle = "" Then Handle = " "
            If blockName = "" Then blockName = " "
            If tag = "" Then tag = " "
            If Loops = "" Then Loops = " "
            If Address = "" Then Address = " "
            If Label1 = "" Then Label1 = " "
            If Label2 = "" Then Label2 = " "
            If Device_Label = "" Then Device_Label = " "
            If Extended_Label = "" Then Extended_Label = " "
            If Qty = "" Then Qty = " "
            If Model_Num = "" Then Model_Num = " "
            If Description = "" Then Description = " "
            If Vendor = "" Then Vendor = " "
            If CSFM_Num = "" Then CSFM_Num = " "
 
            data.AddNew
            data!Handle = "'" & Entity.Handle
            data!blockName = blockName
            data!tag = tag
            data!Address = Address
            data!Label1 = Label1
            data!Label2 = Label2
            data!Device_Label = Device_Label
            data!Extended_Label = Extended_Label
            data!Qty = Qty
            data!Model_Num = Model_Num
            data!Description = Description
            data!Vendor = Vendor
            data!CSFM_Num = CSFM_Num
            data.Update
 
        End If
        End If
 
     Next Entity
 
'************************************************************
'   'HERE is where the code to pull updated table from access goes…
''    Attribs(0).TextString = "THIS IS THE NEW NEW VALUE!"
'
'    ' Get the attributes again
'    Dim newAttribs As Variant
'    newAttribs = blkEntity.GetAttributes
'
'    ' Again, display the tags and values
'    strAttributes = ""
'    For i = LBound(Attribs) To UBound(Attribs)
'        strAttributes = strAttributes + "  Tag: " + _
'        newAttribs(i).TagString + vbCrLf + _
'        "   Value: " + newAttribs(i).TextString
'************************************************************
 
' Close Database
' --------------
    data.Close
    dbs.Close
    Set data = Nothing
    Set dbs = Nothing
    ssnew.Delete
End Sub

[NeoPa]

Hi Tim.

This doesn't seem trivial so I'll get to look at it when I have a little more time on my hands.

I left a link into here from the other thread though, so anyone seeing that will know to come through if interested.

[NeoPa]

I'm sorry to say that I have nothing further to add at this point.

I've gone through the code and there's far too much involved logic there that simply isn't explained. You either need to explain things much much better, which I know is beyond most people to do, or get some paid help with someone who has the time to spend on a single project like this.

A last option would be to break it down into a manageable chunk. You have all your code in there and loads of references to items which are probably not fundamental to your problem. If you can chop out the dead wood and explain your problem precisely and clearly then you might get some takers.

I'm afraid that as it is though, it's way way out of bounds for a question in here.

That's not to say you might not get lucky and find someone interested to help, but I wouldn't advise relying on that too heavily.

[timleonard]

Ok well I thank you anyways...

Ultimately what I am looking for is how to Dim the updated table back into VBA and then how to update the Attribute Block values.

In Excel I believe it is something like...
Dim vAttributeData
vAttributeData = XlSheet.UsedRange
But I don't know how to pull a table

Then once it is dimmed, how to match it up for use.
I think I need to match the "Handle" row in the table to the "Handle in the Attribute Block and when a match is found then update the .textstring.

I am playing around with the following, but I am still off track...

' Get Attribute values
 For Each Entity In ssnew
 
 If Entity.ObjectName = "AcDbBlockReference" Then
   Set blkEntity = Entity
 
 If blkEntity.HasAttributes Then
   Dim newAttribs As Variant
 
   newAttribs = blkEntity.GetAttributes
 
For n = LBound(newAttribs) To UBound(newAttribs)
 
Select Case newAttribs(n).TagString
Case "HANDLE"
 Handle = newAttribs(n).TextString
Case "BLOCKNAME"
 blockName = newAttribs(n).TextString
Case "TAG"
 tag = newAttribs(n).TextString
Case "LOOP"
 Loops = newAttribs(n).TextString
Case "ADDRESS"
 Address = newAttribs(n).TextString
Case "LABEL1"
Label1 = newAttribs(n).TextString
Case "LABEL2"
 Label2 = newAttribs(n).TextString
Case "DEVICE_LABEL"
 Device_Label = newAttribs(n).TextString
Case "EXTENDED_LABEL"
 Extended_Label = newAttribs(n).TextString
Case "QTY"
 Qty = newAttribs(n).TextString
Case "MODEL_NUM"
 Model_Num = newAttribs(n).TextString
Case "DESCRIPTION"
 Description = newAttribs(n).TextString
Case "VENDOR"
 Vendor = newAttribs(n).TextString
Case "CSFM_NUM"
 CSFM_Num = newAttribs(n).TextString
 
 End Select
 Next n
 'Entity(n).Update 'This line does not work
 End If
 End If
 Next Entity