loop through multiple word files and import content control info to excel

[brent.fraser]

Hi everyone,

I am working on an Excel file that will import Word content control information into a row in an Excel spreadsheet and it is working well. What I have been asked is if it is possible to select multiple word files and do the same process. Currently the user browses to a single directory and selects a single file to import. I know that there's the option to use "allowMultiSelect=True" and that's what I want to do. So far for the single files I have:


Option Explicit
Public strPath As String
Dim strFile As String
Dim strWordDocument As String
Dim iReturnValue As String
Public Sub GetFilePath()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Select the Vendor Questionnaire to use"
fd.Filters.Add "Documents", "*.doc; *.docm; *.docx", 1
If fd.Show Then
strWordDocument = fd.SelectedItems(1)
strPath = strWordDocument
strFile = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
End If
iReturnValue = MsgBox("Is this the correct file?" & vbLf + strFile, vbYesNo + vbQuestion, "Is this the Correct File?")
If iReturnValue = vbNo Then
MsgBox "Select the correct file to use."
GetFilePath
End If
End Sub
Sub GetFormData() 'Note: this code requires a reference to the Word Object model
GetFilePath
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim CCtrl As Word.ContentControl
Dim WkSht As Worksheet, i As Long, j As Long
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
If strFile <> "" Then
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strWordDocument, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j) = CCtrl.Range.Text
Next
End With
wdDoc.Close SaveChanges:=False
End If
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

I guess the users are going to have sometimes 50 files in the same directory they need to import, or is it possible to point to a direcory and tell the excel to process all word documents in that directory?

Thanks for the help.

[Doug Robbins]

You can process all of the files in a folder by making use of the DIR statement.

Here is an example of its use:


Sub Convertdoctopdf()
Dim fd As Dialog
Dim strFolder As String
Dim strFile As String
Dim aDoc As Document
Dim fname As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder that contains the files that you want to convert to Portable Document Format."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select a folder."
Exit Sub
End If
End With
strFile = Dir$(strFolder & "*.doc")
While strFile <> ""
Set aDoc = Documents.Open(strFolder & strFile)
fname = aDoc.FullName
fname = Left(fname, Len(fname) - 3) & "pdf"
aDoc.ExportAsFixedFormat fname, wdExportFormatPDF, False, wdExportOptimizeForPrint
aDoc.Close wdDoNotSaveChanges
strFile = Dir$()
Wend
End Sub


You might also want to take a look at the following page of Greg Maxey's website:

http://gregmaxey.mvps.org/word_tip_pages/extract_data_from_content_control_forms.html

[snb]

or



sub M_snb()
c00 = CreateObject("scripting.filesystemobject").getfile(Application.GetOpenFilename).ParentFolder

sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & c00 & "\*.doc*"" /b").stdout.readall, vbCrLf)
for each it in sn
with getobject(it)
for each ct in .contentcontrols
c00=c00 & "|" & ct.range.text
next
.close 0
end with
c00=c00 & vblf
next

sp=split(c00,vblf)
with sheets("sheet1").cells(rows.count,1).end(xlup).offset(1).resize(ubound(sp))
.value= application.transpose(sp)
.texttocolumns ,,,,0,0,0,0,-1,"|"
end with
End Sub

[brent.fraser]

Hi SNB and Doug.

SNB, I tried your code and got a cryptic error that I couldn't figure out. I used a bit of Doug's code and it works. Here's what I eneded up doing:

Sub ExtractWordInfo()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim strFolder As String
Dim strFile As String
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim CCtrl As Word.ContentControl
Dim WkSht As Worksheet, i As Long, j As Long
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
With fd
fd.Title = "Select the folder that contains the files that you want to extract date from."
If fd.Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select a folder."
Exit Sub
End If
End With
strFile = Dir$(strFolder & "*.doc*")
Do While Len(strFile) > 0
MsgBox strFile
i = i + 1
Set wdDoc = Documents.Open(strFolder & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j) = CCtrl.Range.Text
Next
End With
strFile = Dir
Loop
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
wdApp.Quit
End Sub

It seems to be working and doing exactly what I need it to do.

Thanks for the point in the right direction you two.

Brent

[snb]

SNB, I tried your code and got a cryptic error that I couldn't figure out.

Your feedback matches the crypticness of that error. ;)
Can you indicate in which line the error occurs ?

Please notice that the getobject method speeds up your code dramatically, compared to the Documents.opem method.

I noticed I made at least 1 mistake:

Sub M_snb()
c00 = CreateObject("scripting.filesystemobject").getfile(Application.GetOpenFilename).ParentFolder

sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & c00 & "\*.doc*"" /b").stdout.readall, vbCrLf)
For Each it In sn
With getobject(c00 & "\" & it)
For Each ct In .contentcontrols
c01=c01 & "|" & ct.range.text
Next
.close 0
End With
c01=c01 & vblf
Next

sp=split(c01,vblf)
With sheets("sheet1").cells(rows.count,1).end(xlup).offset(1).resize(UBound(sp)+1)
.value= application.transpose(sp)
.texttocolumns ,,,,0,0,0,0,-1,"|"
End With
End Sub

[brent.fraser]

hey SNB,

This time the error isn't as cryptic. The first error was "System Error &H80004005 (-2147467253). Unspecified error."

The last code has the following error "File name or class name not found during Automation operation."

Also, for this one, you have to select a particular file and I want to pick a folder and it processes all *.doc* files in that folder.

Thanks for looking into this.

*cheers*
Brent

[snb]

The picking of the file is only meant to return it's folder (=parentfolder)
If you don't select a file the code won't work.

Are familiar with stepping through the code using F8 ?
an extra check:


Sub M_snb()
c00 = CreateObject("scripting.filesystemobject").getfile(Application.GetOpenFilename).ParentFolder

sn = filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & c00 & "\*.doc*"" /b").stdout.readall, vbCrLf),".doc")
For Each it In sn
With getobject(c00 & "\" & it)
For Each ct In .contentcontrols
c01=c01 & "|" & ct.range.text
Next
.close 0
End With
c01=c01 & vblf
Next

sp=split(c01,vblf)
With sheets("sheet1").cells(rows.count,1).end(xlup).offset(1).resize(UBound(sp)+1)
.value= application.transpose(sp)
.texttocolumns ,,,,0,0,0,0,-1,"|"
End With
End Sub

[brent.fraser]

I just started to use F8 and it runs through the code up to


.Close 0
End With
c01 = c01 & vbLf

then it starts at


For Each it In sn
With GetObject(c00 & "\" & it)


and runs OK. The error happens when it hits


For Each ct In .contentcontrols

for the second time.

I made a folder with just one word file in it so it really should only loop through it once. I don't know why it was going through a second time.


To get the parent folder, couldn't I just get the user to pick the folder using


With fd
fd.Title = "Select the folder that contains the files that you want to extract data from."
If fd.Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select a folder."
Exit Sub
End If
iReturnValue = MsgBox("Is this the correct folder?" & vbLf + strFolder, vbYesNo + vbQuestion, "Is this the Correct Folder?")
Do While iReturnValue = vbNo
MsgBox "Select the correct folder to use."
fd.Show
iReturnValue = MsgBox("Is this the correct folder?" & vbLf + strFolder, vbYesNo + vbQuestion, "Is this the Correct Folder?")
Loop
End With


Forgive me, I am just trying to figure this out and I, by no means, am a programmer.

Brent

[snb]

It means the code errors out if a loaded document doesn't contain any contentcontrols.

You can alway build in a checkpoint:



---
With getobject(c00 & "\" & it)
msgbox c00 & "\" & it
----