FileSearch Object Replacement Code

prpeak

New member
Local time
Today, 09:51
Joined
Aug 7, 2015
Messages
1
I am in the midst of migrating an Access 2003 database to Access 2007 and one of its most important module uses the filesearch object to transfer table data from word files into a table in the databse. I know filesearch isnt supported anymore and I have tried to find solutions that are suitable for my needs but have not found any. I am a novice programmer with no vba experience so help is greatly appreciated!
Code:

Code:
Option Compare Database
Option Explicit

Public Function ImportPathTableData()

Dim objWord As Object
Dim objDoc As Word.Document
Dim db As Database
Dim data As Recordset
Dim bWord As Boolean
Dim strFolderName, strNPID, strTemp As String
Dim tablenb, table, row, column, i As Integer


    Set objWord = CreateObject("Word.Application")
    
    ' Get folder with new files to sort data from
    strFolderName = BrowseFolder("What Folder contains only the new NP reports to fetch data from?")
    If strFolderName = "" Then
      Exit Function
    End If
    
    ' Find and gather files for import in above folder
    With Application.FileSearch
        .NewSearch
        .LookIn = strFolderName
        .SearchSubFolders = False
        .FileName = "NA*"
        .MatchTextExactly = False
        .FileType = msoFileTypeWordDocuments
    End With

    With Application.FileSearch
      ' If files are found, import content
      If .Execute() > 0 Then
          Set db = CurrentDb()
          Set data = db.OpenRecordset("Data", dbOpenTable)
          For i = 1 To .FoundFiles.count
              ' Open in Word
              Set objDoc = Documents.Open(FileName:=.FoundFiles(i))
              ' Extract NA number from file
              ' use row, column variables to mark start and end of said string
              row = InStr(1, .FoundFiles(i), "NA")
              column = InStr(1, .FoundFiles(i), ".doc")
              strNPID = Mid$(.FoundFiles(i), row, column - row)
              ' Check for tables
              tablenb = ActiveDocument.content.Tables.count
              If tablenb > 0 Then
                ' Perform filtering/parsing of each table
                ' one column at a time. Each column is a ResultType
                ' and each row is a RegionType.
                For table = 1 To tablenb
                  row = ActiveDocument.content.Tables(table).Rows.count
                  column = ActiveDocument.content.Tables(table).Columns.count
                  For column = 2 To ActiveDocument.content.Tables(table).Columns.count
                    For row = 2 To ActiveDocument.content.Tables(table).Rows.count
                      data.AddNew
                      data!NPID = strNPID
                      data!ResultID = Nz(DMax("[ResultID]", "Data", "[NPID]='" & strNPID & "'"), 0) + 1
                      ActiveDocument.content.Tables(table).Cell(row:=1, column:=column).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!ResultType = IIf((strTemp = ""), Null, strTemp)
                      ActiveDocument.content.Tables(table).Cell(row:=row, column:=1).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!RegionType = IIf((strTemp = ""), Null, strTemp)
                      ActiveDocument.content.Tables(table).Cell(row:=row, column:=column).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!ResultValue = IIf((strTemp = ""), Null, strTemp)
                      data!DateAdded = Now()
                      data.Update
                    Next row
                  Next column
                Next table
              End If
              ' Now, add records for info to be added manually
              AddDataEntries (strNPID)
              ' Close file in Word now that we are done
              objDoc.Close savechanges:=False
          Next i
      ' else, there were no NA files in said folder
      Else
          MsgBox "There were no files found."
      End If
    End With
   
    If bWord Then objWord.Application.Quit
    
    Set objDoc = Nothing: Set objWord = Nothing

End Function
 
I used the dir function to replace the filesearch object
Here is the fix:

Code:
Dim objWord As Object
Dim objDoc As Word.Document
Dim db As Database
Dim data As Recordset
Dim bWord As Boolean
Dim strFolderName, strNPID, strTemp As String
Dim tablenb, table, row, column, i As Integer
Dim StrMyFile As String


    Set objWord = CreateObject("Word.Application")
    
    ' Get folder with new files to sort data from
    strFolderName = BrowseFolder("What Folder contains only the new NP reports to fetch data from?")
    If strFolderName = "" Then
      Exit Function
    End If
    
    StrMyFile = Dir(strFolderName & "\*NA*")
    Set db = CurrentDb()
    Set data = db.OpenRecordset("Data", dbOpenTable)
    
    'Go through the files in the folder and add the data
      Do While StrMyFile <> ""
         'Open in word
         Set objDoc = Documents.Open(strFolderName & "\" & StrMyFile)
         'extract NPID from file
         strNPID = Replace(StrMyFile, ".doc", "")
         'Check for tables
         tablenb = ActiveDocument.content.Tables.count
         If tablenb > 0 Then
                ' Perform filtering/parsing of each table
                ' one column at a time. Each column is a ResultType
                ' and each row is a RegionType.
                For table = 1 To tablenb
                  row = ActiveDocument.content.Tables(table).Rows.count
                  column = ActiveDocument.content.Tables(table).Columns.count
                  For column = 2 To ActiveDocument.content.Tables(table).Columns.count
                    For row = 2 To ActiveDocument.content.Tables(table).Rows.count
                      data.AddNew
                      data!NPID = strNPID
                      data!ResultID = Nz(DMax("[ResultID]", "Data", "[NPID]='" & strNPID & "'"), 0) + 1
                      ActiveDocument.content.Tables(table).Cell(row:=1, column:=column).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!ResultType = IIf((strTemp = ""), Null, strTemp)
                      ActiveDocument.content.Tables(table).Cell(row:=row, column:=1).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!RegionType = IIf((strTemp = ""), Null, strTemp)
                      ActiveDocument.content.Tables(table).Cell(row:=row, column:=column).Select
                      strTemp = Left$(Selection.Text, Len(Selection.Text) - 2)
                      data!ResultValue = IIf((strTemp = ""), Null, strTemp)
                      data!DateAdded = Now()
                      data.Update
                    Next row
                  Next column
                Next table
        End If
         ' Now, add records for info to be added manually
         AddDataEntries (strNPID)
         'Close Current Document
         Documents(StrMyFile).Close SaveChanges:=wdDoNotSaveChanges
         StrMyFile = Dir()
      Loop
 
   
    objWord.Application.Quit
    
    Set objDoc = Nothing: Set objWord = Nothing
    MsgBox "DONE!!!!!"

End Function
 

Users who are viewing this thread

Back
Top Bottom