I am trying to open Acadfiles and reterieve all the information from the blocks and dump it into access table. where I can update my attributes and again update my drawing as required. This code open the ACAD drawings from a given folder and scroll through each drawing and extract the data by calling fileextractdata procedure. In this procedure when I run this code it does not recogonize some blocks, my block reference variable -- oblockref - remains empty. I have two drawings with one drawing if I select layerblocks the layer which I created the block on works fine and pick all objects. But In other drawings it do not pick blockreference. In the given code I was selecting all the objects on the drawing and then filtering it based on layer. For given layer this code does not work even the block is using the same layer. Could it be because of the name "TEXT-SPECIFICATION"? Is this name too long. But when I keep on moving in the code it picks the right drawing. open it. make it visible and highlight the layers which I filtered in a code. This layer also has a block on it but in code I couldnt reconize any block which was on that layer. Can any one help me on this? Private Sub cmdRetrieveData_Click() Dim acadapp As Object Dim acdocument As Object Dim aCIR2 As AcadCircle Dim objcircle As AcadCircle Dim objdimension As AcadDimension Dim objss As AcadSelectionSet Dim intcodes(0) As Integer Dim varcodevalues(0) As Variant On Error Resume Next Set acadapp = GetObject(, "AutoCAD.application") If Err Then Err.Clear Set acadapp = CreateObject("AutoCAD.application") End If DoCmd.Hourglass True '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 44 strfoldername = "D:\ApprovedDrawings\draws\New Folder\folder1" If Not objfso.folderexists(strfoldername) Then MkDir (strfoldername) End If With Application.FileSearch LookIn = strfoldername Filename = "*.dwg" '%%%%%%%%% begining part of file search looping program If .Execute() > 0 Then MsgBox "There were " & .FoundFiles.Count & _ " file(s) found." For i = 1 To .FoundFiles.Count 'MsgBox .FoundFiles(I) '%%%%%%%%%%%%%%%%%%%%%%%%%%% 'strfiletype = .FoundFiles(i) Call fileExtractiondata(.FoundFiles(i)) ' %%%%%%%%%%end part of file search looping code Next i Else MsgBox "There were no files found." End If End With '%%%%%%%%%%%%%%% Set aCIR2 = Nothing Set objss = Nothing Set acdocument = Nothing Set acadapp = Nothing DoCmd.Hourglass False End Sub '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ::::::::::; Private Sub fileExtractiondata(sfname As String) Dim acadapp As Object Dim acdocument As Object Dim oaccess As Database Dim orecordset As Recordset Dim strquery As String Dim recordno As String Dim oattrib As AcadAttribute Dim objss As AcadSelectionSet Dim objblock As Object Dim strattrib As String Dim intcodes(0) As Integer Dim varcodevalues(0) As Variant Dim oblockref As AcadBlockReference Dim ats As Variant Dim varpick As Variant Dim apath As String Dim blkname As String Dim msgbo As String On Error Resume Next Set oaccess = CurrentDb() strquery = "Select * from Spline_data where DrawingNo =" & 22 'recordno '& "'" Set orecordset = oaccess.OpenRecordset(strquery) Set acadapp = GetObject(, "AutoCAD.application") If Err Then Err.Clear Set acadapp = CreateObject("AutoCAD.application") End If Set acdocument = acadapp.documents.Open(sfname) acadapp.Visible = True intcodes(0) = 8 varcodevalues(0) = "TEXT-SPECIFICATION" Set objss = acdocument.SelectionSets.Add("filterblocks") objss.Select acSelectionSetAll, , , intcodes, varcodevalues objss.Highlight True orecordset.AddNew For Each oblockref In objss ats = oblockref.GetAttributes Dim EA As AcadAttributeReference MsgBox oblockref.Name blkname = oblockref.Name MsgBox oblockref.Layer ats = oblockref.GetAttributes Select Case blkname Case "SPLINE-DATA" For i = 0 To UBound(ats) Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "NO-OF-TEETH" Then orecordset.Fields(2) = ats(i).TextString ' MsgBox ats(I).TextString ElseIf strattrib = "TYPE-FIT" Then orecordset.Fields(3) = ats(i).TextString ElseIf strattrib = "CLASS-FIT" Then orecordset.Fields(4) = ats(i).TextString ElseIf strattrib = "DP-MODULE" Then orecordset.Fields(5) = ats(i).TextString ElseIf strattrib = "PD" Then orecordset.Fields(6) = ats(i).TextString ElseIf strattrib = "BD" Then orecordset.Fields(7) = ats(i).TextString ElseIf strattrib = "PA" Then orecordset.Fields(8) = ats(i).TextString ElseIf strattrib = "SPACEWIDTH-T-THICKNESS" Then orecordset.Fields(9) = ats(i).TextString ElseIf strattrib = "PIN-D" Then orecordset.Fields(10) = ats(i).TextString ElseIf strattrib = "MEASUREMENT-2-PINS" Then orecordset.Fields(11) = ats(i).TextString End If Next i Case "MATERIALS" For i = 0 To UBound(ats) Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "FRICTION-GRADE" Then orecordset.Fields(14) = ats(i).TextString ' MsgBox ats(I).TextString ElseIf strattrib = "FRICTION-COLOR" Then orecordset.Fields(15) = ats(i).TextString ElseIf strattrib = "FRICTION-NOM" Then orecordset.Fields(16) = ats(i).TextString ElseIf strattrib = "CORE-GRADE" Then orecordset.Fields(17) = ats(i).TextString ElseIf strattrib = "HARDNESS" Then orecordset.Fields(18) = ats(i).TextString End If Next i Case "ATTRIBUTES" For i = 0 To UBound(ats) Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "GROOVE-PAT" Then 'MsgBox ats(I).TextString orecordset.Fields(28) = ats(i).TextString ElseIf strattrib = "DISH HEIGHT" Then orecordset.Fields(29) = ats(i).TextString ElseIf strattrib = "WAVES" Then orecordset.Fields(30) = ats(i).TextString ElseIf strattrib = "WAVE-HEIGHT" Then orecordset.Fields(31) = ats(i).TextString End If Next i Case "TOLERANCE" For i = 0 To UBound(ats) MsgBox "TOL" Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "Angular" Then orecordset.Fields(32) = ats(i).TextString ElseIf strattrib = "TOL-1PLC" Then orecordset.Fields(33) = ats(i).TextString ElseIf strattrib = "TOL-2PLC" Then orecordset.Fields(34) = ats(i).TextString ElseIf strattrib = "TOL-3PLC" Then orecordset.Fields(35) = ats(i).TextString ElseIf strattrib = "TON-OD" Then ' MsgBox ats(I).TextString orecordset.Fields(36) = ats(i).TextString ElseIf strattrib = "TON-ID" Then orecordset.Fields(37) = ats(i).TextString ElseIf strattrib = "TON-TOTAL" Then orecordset.Fields(38) = ats(i).TextString End If Next i Case "DESIGN-LEVEL" For i = 0 To UBound(ats) Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "BOM-REV" Then orecordset.Fields(19) = ats(i).TextString ElseIf strattrib = "ROUTING-REV" Then orecordset.Fields(20) = ats(i).TextString ElseIf strattrib = "REF-BASE" Then orecordset.Fields(21) = ats(i).TextString ElseIf strattrib = "DATE" Then orecordset.Fields(22) = ats(i).TextString ElseIf strattrib = "DRAWN-BY" Then orecordset.Fields(23) = ats(i).TextString ElseIf strattrib = "APPROVED-BY" Then orecordset.Fields(24) = ats(i).TextString ' MsgBox ats(I).TextString ElseIf strattrib = "PART-NUMBER" Then orecordset.Fields("PART-NUMBER") = ats(i).TextString ' MsgBox ats(I).TextString ElseIf strattrib = "CAGE-CODE" Then orecordset.Fields(26) = ats(i).TextString ElseIf strattrib = "SCALE" Then orecordset.Fields(27) = ats(i).TextString End If Next i Case "MATING-COMPONENTS" For i = 0 To UBound(ats) Set EA = ats(i) strattrib = (RTrim(ats(i).TagString)) If strattrib = "FRICTION-NO" Then orecordset.Fields(12) = ats(i).TextString ElseIf strattrib = "SC-NO" Then orecordset.Fields(13) = ats(i).TextString End If Next i End Select Next orecordset.Update orecordset.Close acdocument.SelectionSets.Item("filterblocks").Delete acdocument.Close Set oblock = Nothing Set objent = Nothing Set objss = Nothing Set oattrib = Nothing Set oaccess = Nothing Set orecordset = Nothing Set acadapp = Nothing Set acdocument = Nothing MsgBox "done" End Sub
