By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
459,341 Members | 1,619 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 459,341 IT Pros & Developers. It's quick & easy.

VBA to populate access table

P: 52
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



Expand|Select|Wrap|Line Numbers
  1. Sub ExportTitle()  
  2.  
  3. ' Open database and delete old records if exist
  4. ' ---------------------------------------------
  5.     Dim dbs As DAO.Database
  6.     Dim dbsName As String
  7.  
  8.     dbsName = "Project_Drawings.mdb"
  9.     Set dbs = DBEngine.OpenDatabase("C:\Users\tim\Desktop\" & dbsName)
  10.  
  11.  
  12.     Dim activeDoc As AcadDocument
  13.     Dim DocLength As Integer
  14.     Dim Shortlength As Integer
  15.     Dim DwgPath As String
  16.     Dim DwgName As String
  17.     Dim DocName As String
  18.     Set activeDoc = ThisDrawing.Application.ActiveDocument
  19.     DocName = activeDoc.Name
  20.     DocLength = Len(DocName)
  21.  
  22. ' Strip of extension .dwg
  23. ' -------------------------------
  24.     Shortlength = DocLength - 4
  25.     DwgPath = activeDoc.Path
  26.     DwgName = Left(DocName, Shortlength)
  27.  
  28. ' Open recordset in table
  29. ' -----------------------
  30.     Dim data As DAO.Recordset
  31.     Dim TableDef As String
  32.  
  33.  
  34. ' Determine Tables Def
  35. ' --------------------------
  36.     TableDef = "Attribute Report1"
  37.  
  38.     Set data = dbs.OpenRecordset(TableDef, dbOpenDynaset)
  39.  
  40.  
  41. ' Clear old values from table
  42. ' ---------------------------
  43.     dbs.Execute "DELETE * FROM [Attribute Report1]", dbFailOnError
  44.  
  45.     Dim attribs
  46.     Dim Handle As String
  47.     Dim Blockname As String
  48.     Dim Tag As String
  49.     Dim Loops As String
  50.     Dim Address As String
  51.     Dim Label1 As String
  52.     Dim Label2 As String
  53.     Dim Device_Label As String
  54.     Dim Extended_Label As String
  55.     Dim Qty As String
  56.     Dim Model_Num As String
  57.     Dim Description As String
  58.     Dim Vendor As String
  59.     Dim CSFM_Num As String
  60.  
  61.  
  62. ' Make Selection set of Blocks
  63. ' ----------------------------
  64.     Dim ssnew As Object
  65.     Dim setObj As Object
  66.     Dim setColl As AcadSelectionSets
  67.     Dim Entity As AcadEntity
  68.          With activeDoc
  69.           Set setColl = .SelectionSets
  70.           For Each setObj In .SelectionSets
  71.                If setObj.Name = "VBA" Then
  72.                     .SelectionSets.item("VBA").Delete
  73.                     Exit For
  74.                End If
  75.           Next
  76.  
  77.     Set ssnew = activeDoc.SelectionSets.Add("VBA")
  78.     End With
  79.     ssnew.Select acSelectionSetAll
  80.  
  81.  
  82. ' Get Attribute values
  83. ' ---------------------
  84. Dim i
  85.     For Each Entity In ssnew
  86.         attribs = Entity.GetAttributes
  87.         For i = LBound(attribs) To UBound(attribs)
  88.  
  89.             If attribs(i).TagString = "HANDLE" Then
  90.               Handle = attribs(i).TextString
  91.             End If
  92.             If attribs(i).TagString = "BLOCKNAME" Then
  93.               Blockname = attribs(i).TextString
  94.             End If
  95.             If attribs(i).TagString = "TAG" Then
  96.               Tag = attribs(i).TextString
  97.             End If
  98.             If attribs(i).TagString = "LOOP" Then
  99.               Loops = attribs(i).TextString
  100.             End If
  101.             If attribs(i).TagString = "ADDRESS" Then
  102.               Address = attribs(i).TextString
  103.             End If
  104.             If attribs(i).TagString = "LABEL1" Then
  105.               Label1 = attribs(i).TextString
  106.             End If
  107.             If attribs(i).TagString = "LABEL2" Then
  108.               Label2 = attribs(i).TextString
  109.             End If
  110.             If attribs(i).TagString = "DEVICE_LABEL" Then
  111.               Device_Label = attribs(i).TextString
  112.             End If
  113.             If attribs(i).TagString = "EXTENDED_LABEL" Then
  114.               Extended_Label = attribs(i).TextString
  115.             End If
  116.             If attribs(i).TagString = "QTY" Then
  117.               Qty = attribs(i).TextString
  118.             End If
  119.             If attribs(i).TagString = "MODEL_NUM" Then
  120.               Model_Num = attribs(i).TextString
  121.             End If
  122.             If attribs(i).TagString = "DESCRIPTION" Then
  123.               Description = attribs(i).TextString
  124.             End If
  125.             If attribs(i).TagString = "VENDOR" Then
  126.               Vendor = attribs(i).TextString
  127.             End If
  128.             If attribs(i).TagString = "CSFM_NUM" Then
  129.               CSFM_Num = attribs(i).TextString
  130.             End If
  131.  
  132.          Next
  133.  
  134.  
  135. ' Fill Database Table-----------------
  136.  
  137.          If Handle = "" Then Handle = " "
  138.          If Blockname = "" Then Blockname = " "
  139.          If Tag = "" Then Tag = " "
  140.          If Loops = "" Then Loops = " "
  141.          If Address = "" Then Address = " "
  142.          If Label1 = "" Then Label1 = " "
  143.          If Label2 = "" Then Label2 = " "
  144.          If Device_Label = "" Then Device_Label = " "
  145.          If Extended_Label = "" Then Extended_Label = " "
  146.          If Qty = "" Then Qty = " "
  147.          If Model_Num = "" Then Model_Num = " "
  148.          If Description = "" Then Description = " "
  149.          If Vendor = "" Then Vendor = " "
  150.          If CSFM_Num = "" Then CSFM_Num = " "
  151.  
  152.  
  153.          data.AddNew
  154.  
  155.          data!Handle = "'" & Handle
  156.          data!Blockname = Blockname
  157.          data!Tag = Tag
  158.          data!Address = Address
  159.          data!Label1 = Label1
  160.          data!Label2 = Label2
  161.          data!Device_Label = Device_Label
  162.          data!Extended_Label = Extended_Label
  163.          data!Qty = Qty
  164.          data!Model_Num = Model_Num
  165.          data!Description = Description
  166.          data!Vendor = Vendor
  167.          data!CSFM_Num = CSFM_Num
  168.  
  169.          data.Update  '****Gets Stuck Here****
  170.  
  171.     Next
  172.  
  173. ' Close Database
  174. ' --------------
  175.   data.Close
  176.   dbs.Close
  177.   Set data = Nothing
  178.   Set dbs = Nothing
  179.   ssnew.Delete
  180.  
  181. End Sub
  182.  
  183.  
Apr 11 '15 #1

✓ answered by 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.

Share this Question
Share on Google+
7 Replies


NeoPa
Expert Mod 15k+
P: 31,768
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.
Apr 11 '15 #2

P: 52
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...
Apr 11 '15 #3

P: 52
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...
Apr 11 '15 #4

NeoPa
Expert Mod 15k+
P: 31,768
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.
Expand|Select|Wrap|Line Numbers
  1. Sub ExportTitle()  
  2.  
  3. ' Open database and delete old records if exist
  4. ' ---------------------------------------------
  5.     Dim dbs As DAO.Database
  6.     Dim dbsName As String
  7.     Dim activeDoc As AcadDocument
  8.     Dim DocLength As Integer
  9.     Dim Shortlength As Integer
  10.     Dim DwgPath As String
  11.     Dim DwgName As String
  12.     Dim DocName As String
  13.     Dim data As DAO.Recordset
  14.     Dim TableDef As String
  15.     Dim attribs            'Defaults to Variant
  16.     Dim Handle As String
  17.     Dim Blockname As String
  18.     Dim Tag As String
  19.     Dim Loops As String
  20.     Dim Address As String
  21.     Dim Label1 As String
  22.     Dim Label2 As String
  23.     Dim Device_Label As String
  24.     Dim Extended_Label As String
  25.     Dim Qty As String
  26.     Dim Model_Num As String
  27.     Dim Description As String
  28.     Dim Vendor As String
  29.     Dim CSFM_Num As String
  30.     Dim ssnew As Object
  31.     Dim setObj As Object
  32.     Dim setColl As AcadSelectionSets
  33.     Dim Entity As AcadEntity
  34.     Dim i            'Defaults to Variant
  35.  
  36.     dbsName = "Project_Drawings.mdb"
  37.     Set dbs = DBEngine.OpenDatabase("C:\Users\tim\Desktop\" & dbsName)
  38.     Set activeDoc = ThisDrawing.Application.ActiveDocument
  39.     DocName = activeDoc.Name
  40.     DocLength = Len(DocName)
  41.  
  42. ' Strip off extension .dwg
  43. ' -------------------------------
  44.     Shortlength = DocLength - 4
  45.     DwgPath = activeDoc.Path
  46.     DwgName = Left(DocName, Shortlength)
  47.  
  48. ' Open recordset in table
  49. ' -----------------------
  50.  
  51. ' Determine Tables Def
  52. ' --------------------------
  53.     TableDef = "Attribute Report1"
  54.     Set data = dbs.OpenRecordset(TableDef, dbOpenDynaset)
  55.  
  56. ' Clear old values from table
  57. ' ---------------------------
  58.     dbs.Execute "DELETE * FROM [Attribute Report1]", dbFailOnError
  59.  
  60. ' Make Selection set of Blocks
  61. ' ----------------------------
  62.     With activeDoc
  63.         Set setColl = .SelectionSets
  64.         For Each setObj In .SelectionSets
  65.             If setObj.Name = "VBA" Then
  66.                 .SelectionSets.item("VBA").Delete
  67.                 Exit For
  68.             End If
  69.         Next
  70.         Set ssnew = activeDoc.SelectionSets.Add("VBA")
  71.     End With
  72.     ssnew.Select acSelectionSetAll
  73.  
  74. ' Get Attribute values
  75. ' ---------------------
  76.     For Each Entity In ssnew
  77.         attribs = Entity.GetAttributes
  78.         For i = LBound(attribs) To UBound(attribs)
  79.  
  80.             If attribs(i).TagString = "HANDLE" Then
  81.                 Handle = attribs(i).TextString
  82.             End If
  83.             If attribs(i).TagString = "BLOCKNAME" Then
  84.                 Blockname = attribs(i).TextString
  85.             End If
  86.             If attribs(i).TagString = "TAG" Then
  87.                 Tag = attribs(i).TextString
  88.             End If
  89.             If attribs(i).TagString = "LOOP" Then
  90.                 Loops = attribs(i).TextString
  91.             End If
  92.             If attribs(i).TagString = "ADDRESS" Then
  93.                 Address = attribs(i).TextString
  94.             End If
  95.             If attribs(i).TagString = "LABEL1" Then
  96.                 Label1 = attribs(i).TextString
  97.             End If
  98.             If attribs(i).TagString = "LABEL2" Then
  99.                 Label2 = attribs(i).TextString
  100.             End If
  101.             If attribs(i).TagString = "DEVICE_LABEL" Then
  102.                 Device_Label = attribs(i).TextString
  103.             End If
  104.             If attribs(i).TagString = "EXTENDED_LABEL" Then
  105.                 Extended_Label = attribs(i).TextString
  106.             End If
  107.             If attribs(i).TagString = "QTY" Then
  108.                 Qty = attribs(i).TextString
  109.             End If
  110.             If attribs(i).TagString = "MODEL_NUM" Then
  111.                 Model_Num = attribs(i).TextString
  112.             End If
  113.             If attribs(i).TagString = "DESCRIPTION" Then
  114.                 Description = attribs(i).TextString
  115.             End If
  116.             If attribs(i).TagString = "VENDOR" Then
  117.                 Vendor = attribs(i).TextString
  118.             End If
  119.             If attribs(i).TagString = "CSFM_NUM" Then
  120.                 CSFM_Num = attribs(i).TextString
  121.             End If
  122.  
  123. ' Fill Database Table-----------------
  124.             If Handle = "" Then Handle = " "
  125.             If Blockname = "" Then Blockname = " "
  126.             If Tag = "" Then Tag = " "
  127.             If Loops = "" Then Loops = " "
  128.             If Address = "" Then Address = " "
  129.             If Label1 = "" Then Label1 = " "
  130.             If Label2 = "" Then Label2 = " "
  131.             If Device_Label = "" Then Device_Label = " "
  132.             If Extended_Label = "" Then Extended_Label = " "
  133.             If Qty = "" Then Qty = " "
  134.             If Model_Num = "" Then Model_Num = " "
  135.             If Description = "" Then Description = " "
  136.             If Vendor = "" Then Vendor = " "
  137.             If CSFM_Num = "" Then CSFM_Num = " "
  138.  
  139.             data.AddNew
  140.             data!Handle = "'" & Handle
  141.             data!Blockname = Blockname
  142.             data!Tag = Tag
  143.             data!Address = Address
  144.             data!Label1 = Label1
  145.             data!Label2 = Label2
  146.             data!Device_Label = Device_Label
  147.             data!Extended_Label = Extended_Label
  148.             data!Qty = Qty
  149.             data!Model_Num = Model_Num
  150.             data!Description = Description
  151.             data!Vendor = Vendor
  152.             data!CSFM_Num = CSFM_Num
  153.             data.Update
  154.         Next i
  155.     Next Entity
  156.  
  157. ' Close Database
  158. ' --------------
  159.     data.Close
  160.     dbs.Close
  161.     Set data = Nothing
  162.     Set dbs = Nothing
  163.     ssnew.Delete
  164. End Sub
PS. Lines 78 through 121 can be done a lot more straightforwardly using a Select Case statement.
Apr 12 '15 #5

P: 52
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
Apr 13 '15 #6

NeoPa
Expert Mod 15k+
P: 31,768
I'm very happy that helped Tim :-)
Apr 16 '15 #7

P: 52
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).
Jun 5 '16 #8

Post your reply

Sign in to post your reply or Sign up for a free account.