Solved: Print all word files in a folder without opening them

[brettdj]

is this possible?

I have stripped out word resumes and cover letter from 120 email messages on my hard drive using Redemption and File Scripting

I now want to print all files - simple question, do I have to open them?

http://support.microsoft.com/?kbid=201993 says this can be done, although this code fails for me, even when I use the full path


Sub ListDocNamesInFolder()
Dim sMyDir As String
Dim sDocName As String
' The path to obtain the files.
sMyDir = "C:\My Documents\"
sDocName = Dir(sMyDir & "*.DOC")
While sDocName <> ""
' Print the file.
Application.PrintOut FileName: = sDocName
' Get next file name.
sDocName = Dir()
Wend
End Sub


my code


Sub PrintRes()
Dim oApp As Outlook.Application
Dim sItem, oItem
Dim fso As FileSystemObject, fol As Folder, fil As File, a As Attachment
Dim MsgPath As String, SecondSpace As String, Fname As String
MsgPath = "c:\sba"
Set oApp = New Outlook.Application
Set sItem = CreateObject("Redemption.SafeMailItem")
Set oItem = oApp.Session.GetDefaultFolder(16).Items.Add(6)
Set fso = New FileSystemObject
Set fol = fso.GetFolder(MsgPath)
If fso.FolderExists(MsgPath & "\resumes\") = False Then fso.CreateFolder (MsgPath & "\resumes")
For Each fil In fol.Files
sItem.Item = oItem
sItem.Import fil.Path, 3
SecondSpace = InStr(sItem.Item.Subject, " ")
SecondSpace = InStr(SecondSpace + 1, sItem.Item.Subject, " ")
For Each a In sItem.Attachments
Fname = MsgPath & "\resumes\" & Left(sItem.Item.Subject, SecondSpace) & a.Filename
If Right(a.Filename, 3) = "doc" Then a.SaveAsFile Fname
'Application.PrintOut Filename:=Fname
Next
Next
End Sub

[Jacob Hilderbrand]

Trying this, I was able to print a file w/o opening it.

sMyDir = ThisDocument.Path
sDocName = sMyDir & "\New Microsoft Word Document.doc"
Application.PrintOut FileName:=sDocName


This should work for you. I tested it in two files in a folder.

Option Explicit

Sub ListDocNamesInFolder()

Dim Path As String
Dim FName As String

Path = "C:\test\"
FName = Dir(Path & "*.doc")
Do While FName <> ""
Application.PrintOut FileName:=Path & FName
FName = Dir()
Loop

End Sub

[brettdj]

I still get a runtime error 438.

[Jacob Hilderbrand]

What is the error message?

[MOS MASTER]

Option Explicit

Sub ListDocNamesInFolder()

Dim Path As String
Dim FName As String

Path = "C:\test\"
FName = Dir(Path & "*.doc")
Do While FName <> ""
Application.PrintOut FileName:=Path & FName
FName = Dir()
Loop

End Sub


This works for me too. What is your Word version Dave? :yes

[brettdj]

errr ..... I'm embarrased

I was running the code from Excel.

I'l tidy this code up and submit it to the KB. I just need to add on a unzip routine to the original code

Cheers

Dave

[MOS MASTER]

Hahaha Dave..happens to me all the time! :yes (you're so close you overlook it)

Can't wait for it to appear in the KB! :thumb