VBA to populate access table

[timleonard]

I am completely stuck...

The following code is supposed to get the attribute values from an acad drawing and populate an access table. However it only populates one row and stops.

Is it possible to modify the code so that the array will export all the attribute values to the table?

Any assistance is appreciated

Sub ExportTitle()  
 
' Open database and delete old records if exist
' ---------------------------------------------
    Dim dbs As DAO.Database
    Dim dbsName As String
 
    dbsName = "Project_Drawings.mdb"
    Set dbs = DBEngine.OpenDatabase("C:\Users\tim\Desktop\" & dbsName)
 
 
    Dim activeDoc As AcadDocument
    Dim DocLength As Integer
    Dim Shortlength As Integer
    Dim DwgPath As String
    Dim DwgName As String
    Dim DocName As String
    Set activeDoc = ThisDrawing.Application.ActiveDocument
    DocName = activeDoc.Name
    DocLength = Len(DocName)
 
' Strip of extension .dwg
' -------------------------------
    Shortlength = DocLength - 4
    DwgPath = activeDoc.Path
    DwgName = Left(DocName, Shortlength)
 
' Open recordset in table
' -----------------------
    Dim data As DAO.Recordset
    Dim TableDef As String
 
 
' Determine Tables Def
' --------------------------
    TableDef = "Attribute Report1"
 
    Set data = dbs.OpenRecordset(TableDef, dbOpenDynaset)
 
 
' Clear old values from table
' ---------------------------
    dbs.Execute "DELETE * FROM [Attribute Report1]", dbFailOnError
 
    Dim attribs
    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
 
 
' Make Selection set of Blocks
' ----------------------------
    Dim ssnew As Object
    Dim setObj As Object
    Dim setColl As AcadSelectionSets
    Dim Entity As AcadEntity
         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
' ---------------------
Dim i
    For Each Entity In ssnew
        attribs = Entity.GetAttributes
        For i = LBound(attribs) To UBound(attribs)
 
            If attribs(i).TagString = "HANDLE" Then
              Handle = attribs(i).TextString
            End If
            If attribs(i).TagString = "BLOCKNAME" Then
              Blockname = attribs(i).TextString
            End If
            If attribs(i).TagString = "TAG" Then
              Tag = attribs(i).TextString
            End If
            If attribs(i).TagString = "LOOP" Then
              Loops = attribs(i).TextString
            End If
            If attribs(i).TagString = "ADDRESS" Then
              Address = attribs(i).TextString
            End If
            If attribs(i).TagString = "LABEL1" Then
              Label1 = attribs(i).TextString
            End If
            If attribs(i).TagString = "LABEL2" Then
              Label2 = attribs(i).TextString
            End If
            If attribs(i).TagString = "DEVICE_LABEL" Then
              Device_Label = attribs(i).TextString
            End If
            If attribs(i).TagString = "EXTENDED_LABEL" Then
              Extended_Label = attribs(i).TextString
            End If
            If attribs(i).TagString = "QTY" Then
              Qty = attribs(i).TextString
            End If
            If attribs(i).TagString = "MODEL_NUM" Then
              Model_Num = attribs(i).TextString
            End If
            If attribs(i).TagString = "DESCRIPTION" Then
              Description = attribs(i).TextString
            End If
            If attribs(i).TagString = "VENDOR" Then
              Vendor = attribs(i).TextString
            End If
            If attribs(i).TagString = "CSFM_NUM" Then
              CSFM_Num = attribs(i).TextString
            End If
 
         Next
 
 
' 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 = "'" & 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  '****Gets Stuck Here****
 
    Next
 
' Close Database
' --------------
  data.Close
  dbs.Close
  Set data = Nothing
  Set dbs = Nothing
  ssnew.Delete
 
End Sub
 
 

[NeoPa]

If I were to guess it would be that your description of the problem is flawed Tim - in as much as the comment in the code says it gets stuck at that point.

Reading the code it seems clear that the section that writes to the table is outside of the loop. Thus, would only ever run once. In order to get it to write a record for each item in the loop then the code must fall within the loop itself.

As a general rule it is a very good idea to indent code where it makes sense to (Between For ... Next, With ... End With, Do ... Loop, etc). Nevertheless, it can actually be more of a hindrance than a help unless the indenting is done consistently throughout the code. Not that this is a particularly bad example, but it can be such a help to you that I thought I'd mention it.

[timleonard]

Thank you so much for the reply and the pointers...

As I am not skilled in vba and barely know how to put pieces of code together. I will do some research on this. Just please point me in the right direction. Is it that I need to move the the secton that writes the update in to the existing loop and add something like a "next row +1" to the loop. Or does it need something more?

Thanks again for any pointers...

[timleonard]

Awesome...

I got it to work. It was caught up on the primary key field.
Now if possible how do i clean up the code...

[NeoPa]

TimLeonard:
Now if possible how do i clean up the code...

That's easy enough to do, but a little harder to explain.

In this case I think you just need to move the Dim lines to the top and determine how many indents are required at each point.

Sub ExportTitle()  
 
' 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            '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 i            'Defaults to Variant
 
    dbsName = "Project_Drawings.mdb"
    Set dbs = DBEngine.OpenDatabase("C:\Users\tim\Desktop\" & dbsName)
    Set activeDoc = ThisDrawing.Application.ActiveDocument
    DocName = activeDoc.Name
    DocLength = Len(DocName)
 
' Strip off extension .dwg
' -------------------------------
    Shortlength = DocLength - 4
    DwgPath = activeDoc.Path
    DwgName = Left(DocName, Shortlength)
 
' 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
' ----------------------------
    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
        attribs = Entity.GetAttributes
        For i = LBound(attribs) To UBound(attribs)
 
            If attribs(i).TagString = "HANDLE" Then
                Handle = attribs(i).TextString
            End If
            If attribs(i).TagString = "BLOCKNAME" Then
                Blockname = attribs(i).TextString
            End If
            If attribs(i).TagString = "TAG" Then
                Tag = attribs(i).TextString
            End If
            If attribs(i).TagString = "LOOP" Then
                Loops = attribs(i).TextString
            End If
            If attribs(i).TagString = "ADDRESS" Then
                Address = attribs(i).TextString
            End If
            If attribs(i).TagString = "LABEL1" Then
                Label1 = attribs(i).TextString
            End If
            If attribs(i).TagString = "LABEL2" Then
                Label2 = attribs(i).TextString
            End If
            If attribs(i).TagString = "DEVICE_LABEL" Then
                Device_Label = attribs(i).TextString
            End If
            If attribs(i).TagString = "EXTENDED_LABEL" Then
                Extended_Label = attribs(i).TextString
            End If
            If attribs(i).TagString = "QTY" Then
                Qty = attribs(i).TextString
            End If
            If attribs(i).TagString = "MODEL_NUM" Then
                Model_Num = attribs(i).TextString
            End If
            If attribs(i).TagString = "DESCRIPTION" Then
                Description = attribs(i).TextString
            End If
            If attribs(i).TagString = "VENDOR" Then
                Vendor = attribs(i).TextString
            End If
            If attribs(i).TagString = "CSFM_NUM" Then
                CSFM_Num = attribs(i).TextString
            End If
 
' 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 = "'" & 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
        Next i
    Next Entity
 
' Close Database
' --------------
    data.Close
    dbs.Close
    Set data = Nothing
    Set dbs = Nothing
    ssnew.Delete
End Sub

PS. Lines 78 through 121 can be done a lot more straightforwardly using a Select Case statement.

[timleonard]

NeoPa

Thank you so much for your help...
BTW I took your advice and used the select case statement and it worked great...

Thanks Again

[NeoPa]

I'm very happy that helped Tim :-)

[timleonard]

I am so sorry to resurrect this but I have been looking for a way to expand it.

I've posted my new question in VBA to Populate Table (Update).