Copying data from legacy form fields to excel

I have the following code (not all my own work I would like to add) which I use to collect data from legacy form fields from word documents which all sit in one folder and can have any name.

Code:

---

Sub GetFormData()
    'Note: this code requires a reference to the Word object model
    'To do this, go to Tools|References in the VBE, then scroll down to the Microsoft Word entry and check it.
    Application.ScreenUpdating = False
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim FrmField As Word.FormField
    Dim strFolder As String, strFile As String
    Dim WkSht As Worksheet, i As Long, j As Long
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    Set WkSht = ActiveSheet
    i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
        i = i + 1
        Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        With wdDoc
            j = 0
            For Each FmFld In .FormFields
                j = j + 1
                WkSht.Cells(i, j) = FmFld.Result
            Next
        End With
        wdDoc.Close SaveChanges:=False
        strFile = Dir()
    Wend
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

---

What I would like to do modify the script to achieve two things.

Firstly I would like to change the script so I can point it at a directory and the script will do a recursive search for all word documents with a specific name e.g. log.doc.

Secondly, and this is certainly beyond my current VBA skills, the first filed in each of the word documents contains a unique reference which ends up in column A of the excel sheet. I would like a way in which when I run the process again when a document is encountered which has the specified file name then the value of the first field is checked against the contents of column A of the spread sheet and if it already exists then the file is skipped.

I hope this makes sense.

I know this is a big ask but any tips, pointers or guidence on how to achieve either of these would be greatly appreciated.

Regards

Simon

Hello Simon,

Just so I understand what you want to do correctly...

Quote:

---

Firstly I would like to change the script so I can point it at a directory and the script will do a recursive search for all word documents with a specific name e.g. log.doc.

---

1) When you say "point it at a directory", do you mean the directory path should be hard coded in your macro?

2) Currently the macro is returning all Word .doc files but you only want Word files like log*.doc?

3) Is the macro successfully returning the First FormField result?

Hi Leith,

Firstly thanks for taking the time to reply and secondly apologies for my initial post not being clear.

Quote:

---

1) When you say "point it at a directory", do you mean the directory path should be hard coded in your macro?

---

Ideally not. When the current macro is run a browser window is opened allowing me to navigate to a directory.

Quote:

---

2) Currently the macro is returning all Word .doc files but you only want Word files like log*.doc?

---

Kind of. I have a root directory in which there are 200 ish folders. Each of these folder can have additional sub folders. A file called “log.doc” can appear in any folder so I would like the macro to do a recursive search for files specifically called “log.doc”.

Quote:

---

3) Is the macro successfully returning the First FormField result?

---

Yes it is. It is just very inefficient because each time the macro is run it goes through every file again and reads out every FormField, then appends the results to the end of what I previously had which is time consuming and leaves me with many duplicates.

I hope this is clearer?

Thank you

For code to loop through a folder and its sub-folders, see, for example, see my post at: http://www.msofficeforums.com/word-v...html#post96703

Hello Simon,

This will let you choose the parent folder. The macro is set to search all subfolders. You can restrict the search level od subfolders if like.

Let me know if you have any issues with the code.

Code:

---

' Written:  January 31, 2017
' Author:  Leith Ross
' Summary:  Recursively finds a file in a folder. The level of subfolders to search can be specified.
'          The output is saved to a 1-D zero based Variant Array. Each element holds the full path to
'          each found file.


' Subfolder Level Values:
'                        -1 = All Subfolders
'                        0 = Parent Folder Only
'                        1 = Subfolders in the Parent Folder
'                        2 = SubFolders of Subfolders in Parent Folder
'                        etc.




Const Search_All    As Long = -1


Private oShell      As Object


Function FindFile(ByVal FolderPath As Variant, ByRef FilePaths As Variant, Optional ByVal SubfolderLevel As Long)


    Dim n          As Long
    Dim oFile      As Object
    Dim oFiles      As Object
    Dim oFolder    As Variant
    Dim oShell      As Object
       
        If oShell Is Nothing Then
            Set oShell = CreateObject("Shell.Application")
        End If
       
        Set oFolder = oShell.Namespace(FolderPath)
            If oFolder Is Nothing Then
                MsgBox "The Folder '" & FolderPath & "' Does Not Exist.", vbCritical
                SearchSubfolders = False
                Exit Function
            End If
           
            Set oFiles = oFolder.Items
           
            oFiles.Filter 64, "log.doc"
                For Each oFile In oFiles
                    n = UBound(FilePaths)
                    FilePaths(n) = oFile.Path
                    ReDim Preserve FilePaths(n + 1)
                Next oFile
           
            oFiles.Filter 32, "*"
                If SubfolderLevel <> 0 Then
                    For Each oFolder In oFiles
                        Call FindFile(oFolder, FilePaths, SubfolderLevel - 1)
                    Next oFolder
                End If
               
End Function


Sub GetFormData()


    Dim Cell      As Range
    Dim FilePaths  As Variant
    Dim Folder    As Variant
    Dim FrmField  As Object
    Dim i          As Long
    Dim j          As Long
    Dim Path      As Variant
    Dim wdApp      As Object
    Dim wdDoc      As Object
    Dim WkSht      As Worksheet


        Set Folder = GetFolder
        If Folder Is Nothing Then Exit Sub


        Application.ScreenUpdating = False


        Set WkSht = ActiveSheet
        Set Cell = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Offset(1, 0)


        ReDim FilePaths(0)


        Call FindFile(Folder, FilePaths, Search_All)


        Set wdApp = CreateObject("Word.Application")


            For Each Path In FilePaths
                Set wdDoc = wdApp.Documents.Open(Filename:=Path, AddToRecentFiles:=False, Visible:=False)
                    With wdDoc
                        j = 0
                        For Each FmFld In .FormFields
                            j = j + 1
                            Cell.Offset(0, j) = FmFld.Result
                        Next FmFld
                    End With
                Set Cell = Cell.Offset(1, 0)
                wdDoc.Close SaveChanges:=False
            Next Path
 
        Application.ScreenUpdating = True


End Sub
 
Function GetFolder() As Object


    Dim Folder As Variant
   
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count = 1 Then
                Folder = .SelectedItems(1)
                Set GetFolder = CreateObject("Shell.Application").Namespace(Folder)
            End If
        End With


End Function

---

Macropod,

Thanks for taking the time to reply. That code example was very useful and I did get it working with my macro.

Leith,

Thank you so much for this. It works perfectly. I love the way you can set the sub-folder level. I hadn't even considered this as an option.

I really appreciate you taking the time to help me on this.

Hello Simon,

You're welcome. If you have any questions about what the code is doing or you want to modify it, let me know.