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
