Option Explicit
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim scrFso As Object 'a FileSystemObject
Dim scrFolder As Object 'the folder object
Dim scrSubFolders As Object 'the subfolders collection
Dim scrFile As Object 'the file object
Dim scrFiles As Object 'the files object
Dim strDefault As String
Dim strDocName As String
Dim strTargetPath As String
Dim strPrefix As String
Dim strFolder As String
Dim strStartPath As String
Dim strFooterText As String
Dim boolPrefixChange As Boolean
Dim boolSaveAsNew As Boolean
Dim i As Integer
Dim strMacro As String
Dim boolPrint As Boolean
Dim strName As String
Dim wdDoc As Word.Document
Dim iFileNo As Integer
Dim oFrmFlds As FormFields
Dim pIndex As Long
Dim oVar As Variant
Dim newnm As String
Dim oldnm As String
Dim strSignOff As String
Dim strNewPrefix As String
Dim wdApp As Word.Application
Sub EditLetters()
ShowVisualBasicEditor = False
With Choices
.SaveAs.Value = True
End With
Choices.Show
End Sub
Sub OpenAllFilesInFolder(strAction As String, boolSaveAs As Boolean, boolChangeNm As Boolean, strStartLocation As String, strTargetLocation As String, boolPrintOut As Boolean, Optional strText As String)
'where to look
strStartPath = strStartLocation
'and where to put the new files
strTargetPath = strTargetLocation
boolPrefixChange = boolChangeNm
boolSaveAsNew = boolSaveAs
strMacro = strAction
boolPrint = boolPrintOut
strFooterText = strText
Unload Choices
Unload FooterText
Set wdApp = New Word.Application
If strMacro = "FormsFromText" Then
iFileNo = FreeFile()
'Use the name, path and correct extension to make an output file
Open strTargetPath & "Anomaly Report" & ".txt" For Output As iFileNo
Else
'nothing
End If
If boolPrefixChange = True Then strPrefix = InputBox("Please enter the last two letters of the letter prefix for the new filenames", "Naming Conventions", "EE")
'stop the screen flickering
Application.ScreenUpdating = False
'open the files in the start folder and do what you will with them (see below)
DoToAllFiles strStartPath
'search the subfolders for more files
SearchSubFolders strStartPath
'Close the anomaly report file
Close #iFileNo
'open explorer to show the new files
If strTargetPath = "" Then
ShellExecute 0, "open", strStartPath, 0, 0, 1
Else
ShellExecute 0, "open", strTargetPath, 0, 0, 1
End If
'turn updating back on
Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
Sub SearchSubFolders(strStartPath As String)
'starts at path strStartPath and looks at its subfolders and files
'if there are files below it calls DoToAllFiles, which opens them one by one
'once its checked for files, it calls itself to check for subfolders.
If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
'start looking in the place we said to look
Set scrFolder = scrFso.getfolder(strStartPath)
'tell it to be aware of sub folders
Set scrSubFolders = scrFolder.subfolders
For Each scrFolder In scrSubFolders
'tell it to be aware of any files in the sub folder
Set scrFiles = scrFolder.Files
'if there are files below, call openFiles to open them
If scrFiles.Count > 0 Then DoToAllFiles scrFolder.Path
'call ourselves in a moebus whatsit to see if there are subfolders below
SearchSubFolders scrFolder.Path
Next
End Sub
Sub DoToAllFiles(strStartPath As String)
' runs through a folder oPath, opening each file in that folder,
' calling a macro, and then closing each file in that folder
'if we are repeating this it may already be set, otherwise, set it
If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
'set up the supfolders to be searched
Set scrFolder = scrFso.getfolder(strStartPath)
For Each scrFile In scrFolder.Files
strName = scrFile.Name 'the name of this file
Application.StatusBar = strStartPath & "\" & strName 'the status bar is just to let us know where we are
'open the file Name only if it is a word document, because that is all GoTrex understands
If Right(strName, 4) = ".doc" Then
'make sure that the file is editable
Set wdDoc = wdApp.Documents.Open(FileName:=strStartPath & "\" & strName, ReadOnly:=False, Format:=wdOpenFormatAuto)
'Call the macro that performs work on the file pasing a reference to it
If IsEmpty(strFooterText) = True Then strFooterText = ""
Application.Run strMacro, wdDoc
'print the document if you want to
If boolPrint = True Then
wdDoc.PrintOut
Else
'nothing
End If
'If the user has specified to save in a new location
If boolSaveAsNew = True Then
If boolPrefixChange = True Then
'save as with a new name
strNewPrefix = Left(strName, 2) & strPrefix
strDocName = Replace(strName, Left(strName, 4), strPrefix, 5)
wdDoc.SaveAs2 FileName:=strTargetPath & strNewPrefix & strDocName, Fileformat:=wdFormatDocument97
wdDoc.Close
Else
'otherwise save in the new location with the same name
wdDoc.SaveAs2 FileName:=strTargetPath & strName, Fileformat:=wdFormatDocument97
wdDoc.Close
End If
Else
'close saving changes
wdDoc.Close wdSaveChanges
End If
Else
'if the file is not a .doc, ignore it
End If
Next
'return control of status bar to Word
Application.StatusBar = False
End Sub
) but even with one parameter, the open fails. I removed the "& "\" " but that did not sort it either...
