AtoCAD, Access and VBA 2

[PZero]

I have a drawing with several tabs. Each tab is named to match a record in my database, i.e. tab “R001” and record “R001”. The layout of each tab contains several blocks, each with several attributes. Each attribute’s tag is named to match a field name in my database, i.e. tag “FLOOR_AREA” and field “FLOOR_AREA”.

I am trying to put together a VBA app that will determine the current tab name and change the values of the attributes based on the related database record. This information does not need to be saved in the drawing, in fact it would be preferable to have the data accessed ‘on-the-fly’ so that the data viewed is the most recent.

I have hardly any VBA experience so I'm struggling a bit. I've learned quite a lot today, but still really have no clue on where to start with the code. I'm assuming it should be fairly basic, but I could be very wrong.

Thanks,
Chris

 

[TCARPENTER]

Hi PZero,

Have a look at FAQ687-5800 that should get you going on how to pull your attribute information from your blocks.

The next piece, just walking the drawing tabs, would look something like this:

Sub WalkLayoutTabs()
  Dim oLayout As AcadLayout
  
  For Each oLayout In ThisDrawing.Layouts
    Debug.Print oLayout.Name
  Next oLayout
  
End Sub

HTH
Todd

 

[PZero]

Hi, thanks, but I'm trying to pull the data from access to add to the block attributes. Can I pick that up from that FAQ too?

 

[TCARPENTER]

Hi PZero,

Yep. Instead of updating the recordset, you'll just need to read the recordset from Access, and then update the title block attributes.

Post back if you need more help.

HTH
Todd

 

[PZero]

Hi Todd, thanks for getting back to me.

I tried the FAQ687-5800 and its throwing back several errors. I have the title block in the drawing, then via VBAMAN load the DVB file I created, then via VBARUN I run the app. The following messages appear;

First, this error;
Error: -2147217887 - Index or primary key cannot contain null value.

Then this;
Error: 0 -

Then this;
Error: 20 - Resume without error.

Then it repeats errors 0 and 20 every time I click OK. I have to kill AutoCAD via the task manager and restert it.

I can see after going through the code that I can base my solution on it. I just need to get the basis of it working properly. I can upload my files if anyone can help?

 

[PZero]

Ignore the last post, I have a few lines of code missing.

But with everything set up as per the FAQ except for paths, filenames, etc, I still receive an error;

Compile Error: Invalid use of property

It highlights one of the very last lines of 'Public Sub ExportAttribs()', the line being 'rstAttribs = Nothing'.

 

[TCARPENTER]

Hi PZero,

Wow, that's a new one on me... For now, just comment it out, but it may need to read Set rstAttribs = Nothing

HTH
Todd

 

[PZero]

Thanks Todd,

I changed those two lines near the end to;

Set rstAttribs = Nothing
Set cnnDataBse = Nothing

which has fixed the error 'Compile Error: Invalid use of property'.

It now comes up with the following error;

Error: -2147217887 - Index or primary key cannot contain null value.

I will take a look and see if I can find out more abou that error number.

 

[PZero]

I had a look for information on the error message and couldnt see anything that immediately jumped out at me, so I'm just going to forget about that part of it. I think I'll be deleting that part of the code anyway, since all I want to do is read from the database, not write to it.

I'll keep you posted on my progress.

 

[PZero]

Ok, I have started analysing and trying to make what I can of the code. After following the FAQ I have the following;

Public AcadDoc      As AcadDocument      'Current AutoCAD drawing document.
Public cnnDataBse   As ADODB.Connection  'ADO connection to database.
Public rstAttribs   As ADODB.Recordset   'ADO recordset to update.

Public Function vbdPowerSet(strName As String) As AcadSelectionSet

  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        objSelCol.Item(strName).Delete
        Exit For
      End If
    Next
  Set objSelSet = objSelCol.Add(strName)
  Set vbdPowerSet = objSelSet
End Function

Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())

  Dim fType() As Integer, fData()
  Dim index As Long, i As Long
   
  index = LBound(gCodes) - 1
        
  For i = LBound(gCodes) To UBound(gCodes) Step 2
      index = index + 1
      ReDim Preserve fType(0 To index)
      ReDim Preserve fData(0 To index)
      fType(index) = CInt(gCodes(i))
      fData(index) = gCodes(i + 1)
  Next
 
 typeArray = fType: dataArray = fData

End Sub

Public Function Connect(strDatabase As String, strTableName As String)
  
  Dim strSQL As String  'SQL string for extracting recorsets.
  
  strSQL = "SELECT * FROM [" & strTableName & "]"
    
  Set cnnDataBse = New ADODB.Connection
  With cnnDataBse
    .CursorLocation = adUseServer
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .Properties("Data Source").Value = strDatabase
    .Open
  End With
  
  Set rstAttribs = New ADODB.Recordset
  With rstAttribs
    .LockType = adLockPessimistic
    .ActiveConnection = cnnDataBse
    .CursorType = adOpenKeyset
    .CursorLocation = adUseServer
    .Source = strSQL
  End With
  
  rstAttribs.Open , , , , adCmdText
  
  If rstAttribs.RecordCount <> 0 Then
    rstAttribs.MoveFirst
  End If

End Function

Public Function AttribExtract(blkRef As AcadBlockReference)
  
  Dim vArray As Variant   'Attribute array.
  
  If blkRef.HasAttributes Then
    vArray = blkRef.GetAttributes
    AttribExtract = vArray
  End If

End Function

Public Sub ExportAttribs()
  
  Dim ssTitleBlock As AcadSelectionSet  'Selection set/title block to export.
  Dim intData()    As Integer           'DXF code for filtering.
  Dim varData()    As Variant           'DXF code description for filtering.
  Dim varAttribs   As Variant           'Attribute array from title block.
  Dim intAttribCnt As Integer           'Attribute array bounds.
  Dim fldAttribs   As ADODB.Field       'ADO fields from recordset.
  Dim strSearch    As String            'String to search for duplicates.
  Dim blnDuplicate As Boolean           'Duplicate record flag.
  Dim result       As VbMsgBoxResult    'User prompted responses.
  Dim strTblName   As String            'Name of Access table to populate.
  
  ' Defaults.
  '
  On Error GoTo ExportAttribs_Error
  strTblName = "tblDrawings"  ' Table name in database.
  Set AcadDoc = ThisDrawing   ' Current drawing.
      
  ' Build the filter criteria.
  '
  BuildFilter intData, varData, -4, "<and", _
                                  0, "INSERT", _
                                  2, "TitleBlock", _
                                -4, "and>"
                                
  ' Ensure a selection set is not already in memory.
  '
  Set ssTitleBlock = vbdPowerSet("TITLE_BLOCK")
  
  ' Build the selection set.
  '
  ssTitleBlock.Select Mode:=acSelectionSetAll, FilterType:=intData, FilterData:=varData
  
  ' Was anything actually found?
  '
  If ssTitleBlock.Count = 0 Then
    ' The title block wasn't found, notify the user and exit.
    '
    MsgBox "A Standard title block wasn't found, please correct and try again."
    End
  End If
   
  ' Collect the attributes.
  '
  varAttribs = AttribExtract(ssTitleBlock(0))
    
  ' Connect to the title block database.
  '
  Connect "H:\Room Datasheets\TBLOCK2DB\DrawingDatabase.mdb", strTblName
  
  ' Walk the array and find the "Primary Key" field.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    If UCase(varAttribs(intAttribCnt).TagString) = "FILENAME" Then
      ' Now search for the existence of this record in the database
      ' and if there's a match, ask the user how to handle it.
      '
      strSearch = varAttribs(intAttribCnt).TextString
      Exit For
    End If
  Next intAttribCnt
  
  ' Now search the database, duplicate drawing numbers aren't allowed,
  ' if one is found, prompt the user how handle it.
  '
  rstAttribs.Find "[FILENAME] = '" & strSearch & "'"
  
      ' For example using our database's primary key:
      '
      ' rstAttribs.Find "[FileName] = '" & strSearch & "'"

  If rstAttribs.EOF Then
    blnDuplicate = False  ' No existing record found.
  Else
    blnDuplicate = True   ' Existing record found.
  End If
  
  If blnDuplicate Then
    ' Ask the user how to handle the duplicate.
    '
    result = MsgBox("A record with " & strSearch & " already exists, overwrite existing data?", vbQuestion + vbYesNo)
    If result = vbNo Then
      'User doesn't want to overwrite data, just end the routine.
      '
      GoTo ExportAttribs_Exit
    End If
  End If
      
  If Not blnDuplicate Then
    ' Record doesn't exist, add it.
    '
    rstAttribs.AddNew
  End If
 
  ' Walk the array, comparing tag strings to field names,
  ' and populating or updating accordingly.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    For Each fldAttribs In rstAttribs.Fields
      ' Does the tag string value match the field name?
      '
      If UCase(fldAttribs.Name) = UCase(varAttribs(intAttribCnt).TagString) Then
        ' Must have the corresponding tag string and field name,
        ' make sure the attribute is not blank, then update the field.
        '
    If Len(fldAttribs.Value) > 0 Then
      fldAttribs.Value = varAttribs(intAttribCnt).TextString
    End If
        Exit For
      End If
    Next fldAttribs
  Next intAttribCnt
   
  ' Commit the changes.
  '
  rstAttribs.Update

ExportAttribs_Exit:
  
  ' Now close out the recordset and connections
  '
On Error Resume Next
  rstAttribs.Close
  cnnDataBse.Close
  
  Set rstAttribs = Nothing
  Set cnnDataBse = Nothing
  End

ExportAttribs_Error:
  MsgBox "Error: " & Err.Number & " - " & Err.Description
  Resume ExportAttribs_Exit
  
End Sub

Am I right in thinking that all my modifications will take place in 'Public Sub ExportAttribs()' after the line that reads 'varAttribs = AttribExtract(ssTitleBlock(0))'? All I want to do is import the fields of a specific record to the attributes of a block.

 

[TCARPENTER]

Hi PZero,

You are correct about what module to modify.

Your plan, if I understand what you need to accomplish, should be:
[ol]
[li]Collect all the tab names in the drawing.[/li]
[li]Collect all the blocks you need to update on each tab[/li]
[li]Read the database and find any corresponding records, based on tab names.[/li]
[ol a]
[li]if found - update the blocks.[/li]
[li]if not found - add the information?[/li]
[/ol]
[/ol]

With this in mind, you may want to keep Export Attributes around to populate any missing data.

HTH
Todd

 

[PZero]

Hi Todd, hope you are well today.

You are almost correct in what I want to achieve, of course my description becomes clearer the more I learn. All processes will be controlled from my access database, ie; a button press or other action. Command lines and scripts will then be passed to AutoCAD. So, for example;

[ol]
[li]User enters a new record into database in access.[/li]
[li]User presses button marked 'Create datasheet'.[/li]
[li]Button script opens a predefined drawing in AutoCAD, creates a new tab named after the primary key of the current record in access.[/li]
[li]This VBA runs in AutoCAD performing the following;[/li]
[ol a][li]Finds the name of the current tab (the tab just created).[/li]
[li]Finds the record in the database with a primary key of the same name as the current tab.[/li]
[li]Imports the fields of that record to enter into the attributes of the block on the current tab.[/li]
[/ol][/ol]

Export is not needed. All data will be stored in the database and the AutoCAD drawing will only be used for output. If a record is not in the database, it should not exist in the drawing, so maybe delete the tab from the drawing if the corresponding database record is not found?

I will also have a button somewhere in my database to update all the tabs in the drawing to match the records in the database, but I'll worry about that later since the basic functionality will become clear once I have this working.

 

[PZero]

By the way, to make things a bit easier and because of the nature of the data I need to handle, the primary key will be Autonumber.

 

[PZero]

Hi again,

I had a bit of a breakthrough and I have managed to get the script to import fields to the attributes, however, I am receiving a type mismatch error when trying to import from empty fields. How can I get around this and leave an attribute blank if the corresponding field has no data?

My code is as follows;

Public Sub ExportAttribs()
  
  Dim ssTitleBlock As AcadSelectionSet  'Selection set/title block to export.
  Dim intData()    As Integer           'DXF code for filtering.
  Dim varData()    As Variant           'DXF code description for filtering.
  Dim varAttribs   As Variant           'Attribute array from title block.
  Dim intAttribCnt As Integer           'Attribute array bounds.
  Dim fldAttribs   As ADODB.Field       'ADO fields from recordset.
  Dim strSearch    As String            'String to search for duplicates.
  Dim blnDuplicate As Boolean           'Duplicate record flag.
  Dim result       As VbMsgBoxResult    'User prompted responses.
  Dim strTblName   As String            'Name of Access table to populate.
  
  ' Defaults.
  '
  On Error GoTo ExportAttribs_Error
  strTblName = "tblDrawings"  ' Table name in database.
  Set AcadDoc = ThisDrawing   ' Current drawing.
      
  ' Build the filter criteria.
  '
  BuildFilter intData, varData, -4, "<and", _
                                  0, "INSERT", _
                                  2, "TitleBlock", _
                                -4, "and>"
                                
  ' Ensure a selection set is not already in memory.
  '
  Set ssTitleBlock = vbdPowerSet("TITLE_BLOCK")
  
  ' Build the selection set.
  '
  ssTitleBlock.Select Mode:=acSelectionSetAll, FilterType:=intData, FilterData:=varData
  
  ' Was anything actually found?
  '
  If ssTitleBlock.Count = 0 Then
    ' The title block wasn't found, notify the user and exit.
    '
    MsgBox "A Standard title block wasn't found, please correct and try again."
    End
  End If
    
    
    
    
    
    
  ' HERES WHERE I NEED TO FIND THE TAB NAME AND USE IT TO IDENTIFY WHICH RECORD TO IMPORT THE ATTRIBUTES FROM ******************
     
  ' Collect the attributes.
  '
  varAttribs = AttribExtract(ssTitleBlock(0))
    
  ' Connect to the title block database.
  '
  Connect "H:\Room Datasheets\TBLOCK2DB\DrawingDatabase.mdb", strTblName
  
  ' Walk the array and find the "Primary Key" field.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    If UCase(varAttribs(intAttribCnt).TagString) = "FILENAME" Then
      strSearch = varAttribs(intAttribCnt).TextString
      Exit For
    End If
  Next intAttribCnt
  
  
  
  
  
  ' HERES WHERE I CHECK TO SEE IF THE RECORD EXISTS ****************************************************************************
  
  ' Now search the database, duplicate drawing numbers aren't allowed,
  ' if one is found, prompt the user how handle it.
  '
  rstAttribs.Find "[FILENAME] = '" & strSearch & "'"
  
      ' For example using the database's primary key:
      '
      ' rstAttribs.Find "[FileName] = '" & strSearch & "'"

  If rstAttribs.EOF Then
    blnDuplicate = False  ' No existing record found.
  Else
    blnDuplicate = True   ' Existing record found.
  End If
  
  If Not blnDuplicate Then
    ' Record doesn't exist, inform user.
    '
    result = MsgBox("Record not found")
  End If
  
  
  
  
  ' HERES WHERE I NEED TO IMPORT FIELDS TO THE ATTRIBUTES **********************************************************************
 
  ' Walk the array, comparing tag strings to field names,
  ' and populating or updating accordingly.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    For Each fldAttribs In rstAttribs.Fields
      ' Does the tag string value match the field name?
      '
      If UCase(fldAttribs.Name) = UCase(varAttribs(intAttribCnt).TagString) Then
        ' Must have the corresponding tag string and field name,
        ' then update the field.
        '
      varAttribs(intAttribCnt).TextString = fldAttribs.Value
        Exit For
      End If
    Next fldAttribs
  Next intAttribCnt
   
  ' Commit the changes.
  '
  rstAttribs.Update
  
  
  
  
  ' EXIT THE DATABASE **********************************************************************************************************

ExportAttribs_Exit:
  
  ' Now close out the recordset and connections
  '
On Error Resume Next
  rstAttribs.Close
  cnnDataBse.Close
  
  Set rstAttribs = Nothing
  Set cnnDataBse = Nothing
  End

ExportAttribs_Error:
  MsgBox "Bollocks! Error " & Err.Number & " - " & Err.Description
  Resume ExportAttribs_Exit
  
End Sub

 

[TCARPENTER]

Hi PZero,

Try something along the lines of:

If UCase(fldAttribs.Name) = UCase(varAttribs(intAttribCnt).TagString) [b][purple]And Not IsNull(fldAttribs.Value)[/purple][/b] Then
  ' Must have the corresponding tag string and field name,
  ' then update the field.
  '
  varAttribs(intAttribCnt).TextString = fldAttribs.Value
  Exit For
End If

HTH
Todd

 

[PZero]

Good Morning,

Thanks for the code snippet Todd. It came in handy and I can now delete a field in a record in the database, and have the appropriate attribute blanked in AutoCAD. The code I now have is as follows;

  ' Walk the array, comparing tag strings to field names,
  ' and populating or updating accordingly.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    For Each fldAttribs In rstAttribs.Fields
      ' Does the tag string value match the field name?
      '
      If UCase(fldAttribs.Name) = UCase(varAttribs(intAttribCnt).TagString) And Not IsNull(fldAttribs.Value) Then
  ' Must have the corresponding tag string and field name,
  ' then update the field.
  '
      fldFull = True
      Else
      fldFull = False
      End If
  
      If Not fldFull Then
      varAttribs(intAttribCnt).TextString = ""
      Else
      varAttribs(intAttribCnt).TextString = fldAttribs.Value

    Exit For
  End If
       
    Next fldAttribs
  Next intAttribCnt
   
  ' Commit the changes.
  '
  rstAttribs.Update

My drawing will have multiple layouts. I now need to add to the script so it will do the following;

[ol]
[li]determine the name of the current layout.[/li]
[li]find the corresponding record in the database (layout name will also be primary key).[/li]
[li]update the block on that layout from the record in the database.[/li][/ol]

I have found the following script which I may be able to use as the basis of a new subroutine;

Sub ad_LayoutIsolate()
  Dim fType(0 To 1) As Integer, fData(0 To 1)
  Dim DataSS As AcadSelectionSet
  Dim dwgEnt As AcadEntity
  Dim adLayout As AcadLayout
  Dim itemType As String
  Dim itemCount As Integer
  
  On Error Resume Next
'first create a selection set of all items of the type you want to work with
  Set DataSS = ThisDrawing.SelectionSets("DataSS")
  If Err Then Set DataSS = ThisDrawing.SelectionSets.Add("DataSS")
  DataSS.Clear
  itemType = "TEXT"  'this holds the type of entity we'll be collecting
  fType(0) = 0: fData(0) = itemType
  fType(1) = 8: fData(1) = "*"     'Here you specify the layer. We'll use all layers
  DataSS.Select acSelectionSetAll, , , fType, fData

'now we cycle through all the layouts
  For Each adLayout In ThisDrawing.Layouts
    itemCount = 0
    ThisDrawing.ActiveLayout = adLayout
    For Each dwgEnt In DataSS
'this is where the items residing on the current layout are culled
      If LCase(ThisDrawing.ObjectIdToObject(dwgEnt.OwnerID).Layout.Name) = LCase(adLayout.Name) Then
        itemCount = itemCount + 1
      End If
    Next dwgEnt
    MsgBox "Report for " & itemType & " Entities-" & vbCrLf & _
           "Total in the active drawing: " & DataSS.Count & vbCrLf & _
           "Total on layout " & adLayout.Name & ": " & itemCount
  Next adLayout
  DataSS.Delete
End Sub

Am I barking up the wrong tree? Is is a simple case of appending references to the block with 'ThisDrawing.ActiveLayout'?

 

[TCARPENTER]

Hi PZero,

1. determine the name of the current layout.

This line should do it:

strLayoutName = Thisdrawing.Activelayout.Name

2. find the corresponding record in the database (layout name will also be primary key).

Just add the active layout name to your search criteria:

  ' HERES WHERE I CHECK TO SEE IF THE RECORD EXISTS ****************************************************************************
  
  ' Now search the database, duplicate drawing numbers aren't allowed,
  ' if one is found, prompt the user how handle it.
  '
  rstAttribs.Find "[FILENAME] = '" & strSearch & "' [b][purple] AND [LAYOUT] = '" & strLayoutName & "'"[/purple][/b]
  
      ' For example using the database's primary key:
      '
      ' rstAttribs.Find "[FileName] = '" & strSearch & "'"

  If rstAttribs.EOF Then
    blnDuplicate = False  ' No existing record found.
  Else
    blnDuplicate = True   ' Existing record found.
  End If
  
  If Not blnDuplicate Then
    ' Record doesn't exist, inform user.
    '
    result = MsgBox("Record not found")
  End If

3. update the block on that layout from the record in the database.

You've already got that part. So, yes the code you posted could easily be modified to do what you want. Looks like you're on your way!

HTH
Todd

 

[PZero]

Todd,

Thank you very much for all the help you are giving me.

I have now made the following changes;

  On Error GoTo ExportAttribs_Error
  strTblName = "tblDrawings"                        ' Table name in database.
  strLayoutName = ThisDrawing.ActiveLayout.Name     ' Current layout name
  Set AcadDoc = ThisDrawing                         ' Current drawing.

rstAttribs.Find "[FILENAME] = '" & strLayoutName & "'"

So the script is now using the record with the primary key that matches the layout name, which is correct. However, when it imports the fields from the database, it will only update the block that resides on the first layout. So if I go to 'layout002' and run the script, it imports the correct record, but updates the block on 'layout001' instead. How do I update the block on the current layout?

 

[TCARPENTER]

Hi PZero,

It sounds like you still have a selection set in memory. You'll need to make your layout current and then select your blocks, or modify the selection set filter codes to select only blocks residing on a particular layout.

HTH
Todd

 

[PZero]

The layout I want to update is current before I run the script, but it still imports the record into the block on the first layout, so if I understand correctly, it can't be a problem with an existing selection set still being in memory.

So I must have to modify the selection set filter codes to select only blocks residing on the current layout. I have no idea where to start

A quick google didn't seem very helpful either.