Hi helpserv,

The Dir$() function can't do subdirectories (as explained in the
Remarks section of the VBA help topic about the function). To work
your way down through all subdirectories, you need a completely
different tool, the FileSystemObject.

First, in the VBA editor, go to Tools References and put a check
mark next to Microsoft Scripting Runtime. Without that, you'd get
compiler errors from the following code.

The subroutine PrintSubfolders does something called 'recursion' --
that is, it calls itself over and over, each time going one level
deeper in the folder tree until there are no more subfolders. At each
folder along the way, it does the modify-and-print on each .doc file
in that folder.

Another point worth noting is that this version uses a Range object to
add the fields to the footer instead of moving the cursor around with
the Selection. That makes the macro faster, since Word doesn't have to
spend time redrawing the screen.

Public Sub OnlyPrint()
Dim fs As FileSystemObject, oFolder As Folder
Dim PathToUse As String

With Dialogs(wdDialogCopyFile)
If .Display 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

Set fs = CreateObject("Scripting.FileSystemObject")
Set oFolder = fs.GetFolder(PathToUse)

PrintSubfolders oFolder
End Sub

Private Sub PrintSubfolders(oRoot As Folder)
Dim oSubFolders As Folders, oChild As Folder
Dim oFileCollection As Files, oFile As File
Dim myDoc As Document
Dim myRange As Range

' handle files in this folder
Set oFileCollection = oRoot.Files
For Each oFile In oFileCollection
If InStr(oFile.name, ".doc") Then
Set myDoc = Documents.Open( _
oRoot.Path & "\" & oFile.name)

With myDoc
Set myRange = .Sections(1) _
.Footers(wdHeaderFooterPrimary).Range
NormalTemplate.AutoTextEntries("Filename and path") _
.Insert Whe=myRange, RichText:=True

Set myRange = .Sections(1) _
.Footers(wdHeaderFooterPrimary).Range
myRange.InsertAfter vbTab
Set myRange = .Sections(1) _
.Footers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
NormalTemplate.AutoTextEntries("Print Date") _
.Insert Whe=myRange, RichText:=True

Set myRange = .Sections(1) _
.Footers(wdHeaderFooterPrimary).Range
myRange.InsertAfter vbTab
Set myRange = .Sections(1) _
.Footers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
NormalTemplate.AutoTextEntries("Page X of Y") _
.Insert Whe=myRange, RichText:=True

.PrintOut Background:=False
.Close Savechanges:=wdDoNotSaveChanges
End With
End If
Next oFile

' get collection of this folder's child subfolders
Set oSubFolders = oRoot.SubFolders
For Each oChild In oSubFolders
' recursive call
PrintSubfolders oChild
Next oChild
End Sub

--
Regards,
Jay Freedman http://aspnet2.com/mvp.ashx?JayFreedman
Microsoft Word MVP FAQ: http://word.mvps.org

(helpserv) wrote:

Can someone suggest what should be modified to the macro code below,
which will permit including "sub folders" when running the following
macro within Word 2003? Thanks. By the way, the use of this macro is
for a non profit non-discriminatory youth program and your assistance
will make a difference. Thank you for your consideration.

The macro does work perfectly to add to the footer the filename and
path, print date, and page x of y and then prints the document. What
we spent the last 2 weeks trying to do is for the macro to run on
subfolders since we have many documents and many folders. We note
when running the macro as is that we have had to manually go into
every folder individually and then run the macro. Permitting
subfolders to run in addition will save a considerable amount of time
and ensure we have left no folder/ or sub folder out of our print
task. Thank you.


' onlyprint Macro
' Macro created 09/14/2004 by youth org
'

Public Sub onlyprint()
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document

With Dialogs(wdDialogCopyFile)
If .Display 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With


'Close any documents that may be open
If Documents.Count 0 Then
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

If Left(PathToUse, 1) = Chr(34) Then
PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
End If

myFile = Dir$(PathToUse & "*.doc")

While myFile ""
Set myDoc = Documents.Open(PathToUse & myFile)
If ActiveWindow.View.SplitSpecial wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or
ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView =
wdSeekCurrentPageHeader
End If
Selection.Font.Size = 7
NormalTemplate.AutoTextEntries("Filename and path").Insert Whe=
_
Selection.Range, RichText:=True
Selection.TypeText Text:=" "
NormalTemplate.AutoTextEntries("Print Date").Insert
Whe=Selection.Range _
, RichText:=True
Selection.TypeText Text:=" "
NormalTemplate.AutoTextEntries("Page X of Y").Insert
Whe=Selection. _
Range, RichText:=True

'print and close the document
myDoc.PrintOut
myDoc.Close Savechanges:=wdDoNotSaveChangesClose
myFile = Dir$()

Wend
End Sub