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.
any help would be appreciated
Thanks
Graham
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 Functionany help would be appreciated
Thanks
Graham
