Copying data from legacy form fields to excel

[si666]

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.


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

[Leith Ross]

Hello Simon,

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


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?

[si666]

Hi Leith,

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


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.


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”.


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

[macropod]

For code to loop through a folder and its sub-folders, see, for example, see my post at: http://www.msofficeforums.com/word-vba/30239-macro-change-convert-delete-txt-files-folder.html#post96703

[Leith Ross]

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.



' 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

[si666]

Macropod,

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

[si666]

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.

[Leith Ross]

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.