Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Autocad export attributes to access

Status
Not open for further replies.

sytech

Technical User
Oct 27, 2003
14
GB
Ive tried to implement Todd Carpenters FAQ for extracting data from drawings to Access but keep getting errors have posted code below:

Database primary key is called filename drawing title block is called drawingtitle primary key is drawingID I keep getting error 3265 - item cannot be found in the collection corresponding to the requested name or ordinal.
Code:
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 Sub ExportAttribs()
  '
  ' Title     : ExportAttribs
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 11:57:39 AM
  ' Last Edit : 03/05/2005 11:57:39 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used as the main workhorse - returns nothing.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) AttribExtract
  '   2) BuildFilter
  '   3) Connect
  '   4) vbdPowerSet
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strTblName - This the name of the database table
  '                      to be populated by the title block
  '                      attributes.
  '      2) AcadDoc    - Current AutoCAD drawing document must be global.
  '      3) cnnDataBse - Connection to database must be global.
  '      4) rstAttribs - Recordset to update/append to database, must be global.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    ExportAttribs "Drawings"
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 11:57:39 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' ExportAttribs begins here:
  ' ——————————————————————————————————————————————————
  
  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, "drawingtitle", _
                                -4, "and>"
                                
  ' Ensure a selection set is not already in memory.
  '
  Set ssTitleBlock = vbdPowerSet("drawingtitle")
  
  ' 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 "C:\Documents and Settings\Graham\My Documents\drawingsdatabase.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 = ThisDrawing.Path & "\" & ThisDrawing.Name

      'strSearch = varAttribs(intAttribCnt).TextString
      Exit For
    End If
  Next intAttribCnt
  rstAttribs.Fields("drawingid").Value = strSearch
  
  ' 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
  fldAttribs.Value = IIf(Len(varAttribs(intAttribCnt).TextString) = 0, "N/A", 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
  
  End

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


Public Function Connect(strDatabase As String, strTableName As String)
  '
  ' Title     : Connect
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 08:57:36 AM
  ' Last Edit : 03/05/2005 08:57:36 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used to connect to an
  '   ADO record source.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strDatabase - The database file location.
  '      2) strTableName - Table within the database to open.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    Connect "Drawings.mdb", strTblName
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 08:57:36 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' Connect begins here:
  ' ——————————————————————————————————————————————————
  
  Dim strSQL As String  'SQL string for extracting recorsets.
  
  'strSQL = "SELECT * FROM [tbldrawings]"


  
  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)
  '
  ' Title     : AttribExtract
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 08:49:24 AM
  ' Last Edit : 03/05/2005 08:49:24 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used to extract attributes
  '   from a supplied block, and return the array
  '   to the calling function.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) blkRef - Inserted block (not the definition)
  '                  to extract attributes.
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    AttribExtract(ssTitleBlock(0))
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 08:49:24 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' AttribExtract begins here:
  ' ——————————————————————————————————————————————————
  
  Dim vArray As Variant   'Attribute array.
  
  If blkRef.HasAttributes Then
    vArray = blkRef.GetAttributes
    AttribExtract = vArray
  End If

End Function
Public Function BuildFilter(typeArray, dataArray, ParamArray gCodes())
  '
  ' Title     : BuildFilter
  '
  ' Version   : ?.?.?
  ' Author(s) : Frank Oquendo
  ' Created   : 03/20/2002 11:17:43 AM
  ' Last Edit : 03/20/2002 11:17:43 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This routine is used to fill a pair of variants
  '   with arrays for use as a selection set filter.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) typeArray - An integer array of DXF codes.
  '      2) dataArray - A Variant array of DXF code descriptions.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    BuildFilter intData, varData, -4, "<and", _
  '                                     0, "INSERT", _
  '                                     2, "TB*", _
  '                                  -4, "and>"
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/20/2002 11:17:43 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' BuildFilter begins here:
  ' ——————————————————————————————————————————————————

  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 Function

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  '
  ' Title     : vbdPowerSet
  '
  ' Version   : 1.0.0
  ' Author(s) : Randall Rath
  ' Created   : 03/20/2002 01:45:37 PM
  ' Last Edit : 03/20/2002 01:45:37 PM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function to add a new selection set by name, and check
  '   for an existing selection set.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    Set ssTitleBlocks = vbdPowerSet("TITLEBLOCKS_SSET")
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strName - A string for any named sets within the
  '                   drawing for vbdPowerSet to search.
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/20/2002 01:45:37 PM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' vbdPowerSet begins here:
  ' ——————————————————————————————————————————————————

  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = AcadDoc.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

any help would be appreciated
Thanks
Graham
 
Hi Guys

solved problem above but now it says record exists do you want to over write, answering yes it goes to the first record in the database and over writes the data apart from the primary key which it over writes with a blank entry tried several primary keys it does the same each time.

Any ideas appreciated.


Graham
 
Hi Graham,

Sorry you're having trouble with the FAQ I posted. First, have you resolved your porblem and second have you made any changes other than what you've posted earlier.

Let me know.

Todd
 
Hi Todd

Happy new year

I have tried using a different primary key basically the drawing number in the title block and in the database but it does the same thing says record exists and then goes to the 1st record and puts a blank in the primary key and enters correct data in the remaining columns.

I also tried doing it the other way by importing attributes but that just says no records to update

I dont know if it makes any difference I am using Access 2003 and Acad 2004

Any help would be very much appreciated

Regards
Graham
 
Hi Graham,

Versions shouldn't matter although it's possible the Sandbox mode is giving you some grief, but can you post the changes you've made to the code? You mentioned you solved your first problem - so I'm wondering if maybe in the fix there's something that needs to be addressed.

I'll check back first thing in the morning.

Todd
 
Morning Todd

I assume it will be morning when you read this I believe your in US near Detroit I'm in UK on East Coast so about 8 hours time difference, any way below is full code as it is at the moment, to cure the previous error 3265 I changed the name of the Primary ID in both acad and access and it solved that.

Code:
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 AttribExtract(blkRef As AcadBlockReference)
  '
  ' Title     : AttribExtract
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 08:49:24 AM
  ' Last Edit : 03/05/2005 08:49:24 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used to extract attributes
  '   from a supplied block, and return the array
  '   to the calling function.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) blkRef - Inserted block (not the definition)
  '                  to extract attributes.
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    AttribExtract(ssTitleBlock(0))
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 08:49:24 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' AttribExtract begins here:
  ' ——————————————————————————————————————————————————
  
  Dim vArray As Variant   'Attribute array.
  
  If blkRef.HasAttributes Then
    vArray = blkRef.GetAttributes
    AttribExtract = vArray
  End If

End Function


Public Sub ExportAttribs()
  '
  ' Title     : ExportAttribs
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 11:57:39 AM
  ' Last Edit : 03/05/2005 11:57:39 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used as the main workhorse - returns nothing.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) AttribExtract
  '   2) BuildFilter
  '   3) Connect
  '   4) vbdPowerSet
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strTblName - This the name of the database table
  '                      to be populated by the title block
  '                      attributes.
  '      2) AcadDoc    - Current AutoCAD drawing document must be global.
  '      3) cnnDataBse - Connection to database must be global.
  '      4) rstAttribs - Recordset to update/append to database, must be global.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    ExportAttribs "Drawings"
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 11:57:39 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' ExportAttribs begins here:
  ' ——————————————————————————————————————————————————
  
  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, "drawingtitle", _
                                -4, "and>"
                                
  ' Ensure a selection set is not already in memory.
  '
  Set ssTitleBlock = vbdPowerSet("drawingTitle")
  
  ' 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 "C:\Documents and Settings\Graham\My Documents\drawingsdatabase.mdb", strTblName
  
  ' Walk the array and find the "Primary Key" field.
  '
  For intAttribCnt = LBound(varAttribs) To UBound(varAttribs)
    If UCase(varAttribs(intAttribCnt).TagString) = "drawingid" 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
      strSearch = ThisDrawing.Path & "\" & ThisDrawing.Name
      

      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.Fields("drawingid").Value = strSearch
  
rstAttribs.Find "[drawingid] = '" & strSearch & "'"
  
      ' For example using our database's primary key:
      '
      ' rstAttribs.Find "[drawingid] = '" & 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
      fldAttribs.Value = IIf(Len(varAttribs(intAttribCnt).TextString) = 0, "N/A", 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



Public Function BuildFilter(typeArray, dataArray, ParamArray gCodes())
  '
  ' Title     : BuildFilter
  '
  ' Version   : ?.?.?
  ' Author(s) : Frank Oquendo
  ' Created   : 03/20/2002 11:17:43 AM
  ' Last Edit : 03/20/2002 11:17:43 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This routine is used to fill a pair of variants
  '   with arrays for use as a selection set filter.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) typeArray - An integer array of DXF codes.
  '      2) dataArray - A Variant array of DXF code descriptions.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    BuildFilter intData, varData, -4, "<and", _
  '                                     0, "INSERT", _
  '                                     2, "TB*", _
  '                                  -4, "and>"
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/20/2002 11:17:43 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  ' BuildFilter begins here:
  ' ——————————————————————————————————————————————————

 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 Function



Public Function Connect(strDatabase As String, strTableName As String)
  '
  ' Title     : Connect
  '
  ' Version   : 1.0.0
  ' Author(s) : Todd Carpenter
  ' Created   : 03/05/2005 08:57:36 AM
  ' Last Edit : 03/05/2005 08:57:36 AM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function is used to connect to an
  '   ADO record source.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strDatabase - The database file location.
  '      2) strTableName - Table within the database to open.
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    Connect "Drawings.mdb", strTblName
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/04/2005 08:57:36 AM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' Connect begins here:
  ' ——————————————————————————————————————————————————
  
  Dim strSQL As String  'SQL string for extracting recordsets.
  
  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 vbdPowerSet(strName As String) As AcadSelectionSet
  '
  ' Title     : vbdPowerSet
  '
  ' Version   : 1.0.0
  ' Author(s) : Randall Rath
  ' Created   : 03/20/2002 01:45:37 PM
  ' Last Edit : 03/20/2002 01:45:37 PM, TDC
  '
  ' Description:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯
  '   This function to add a new selection set by name, and check
  '   for an existing selection set.
  '
  ' Additional files/functions required:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '   1) None
  '
  ' Example usage:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    Set ssTitleBlocks = vbdPowerSet("TITLEBLOCKs_SSET")
  '
  ' Requires the following variables:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    * Input assignments
  '      1) strName - A string for any named sets within the
  '                   drawing for vbdPowerSet to search.
  '
  ' Updates:
  ' ¯¯¯¯¯¯¯¯
  ' 03/20/2002 01:45:37 PM - 1.0.0 - TDC
  '    1) Initially created
  '
  ' Future considerations:
  ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
  '    1) None
  '
  ' vbdPowerSet begins here:
  ' ——————————————————————————————————————————————————

  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

Primary Key is drawingid in access and acad

Rgds
Graham



 
Hi Graham,

The line of code in red,

Code:
 ' Now search the database, duplicate drawing numbers aren't allowed,
  ' if one is found, prompt the user how handle it.
    [red]rstAttribs.Fields("drawingid").Value = strSearch[/red]
  
rstAttribs.Find "[drawingid] = '" & strSearch & "'"

is setting your strSearch value to "" and is causing the blank statement - delete the line in red and see if that fixes your troubles.

HTH
Todd
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top