Attribute VB_Name = "VSReplace"
'bolay.co 2013
'Sylvain Bolay
'Last update: may 14, 2013
 
'Inspired from http://word.tips.net/T003783_Changing_Information_in_Multiple_Documents.html
Public Sub VSReplace()
    Dim Directory As String
    Dim FType As String
    Dim FName As String
 
    FType = "*.doc"
    FLocation = "C:\VS"
 
    Dim colFiles As New Collection
    RecursiveDir colFiles, FLocation , FType, True
 
    Dim vFile As Variant
    For Each vFile In colFiles
 
        ' Open the file
        Documents.Open FileName:=vFile
 
	' Edit the file
        Call FindAndReplace
 
        ' save and close the current document
        ActiveDocument.Close wdSaveChanges
 
     Next vFile
End Sub
 
'From http://www.ammara.com/access_image_faq/recursive_folder_search.html
Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)
 
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
 
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop
 
    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
 
        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If
 
End Function
 
'From http://www.ammara.com/access_image_faq/recursive_folder_search.html
Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function
 
'Modified from http://www.word.mvps.org/FAQs/MacrosVBA/FindReplaceAllWithVBA.htm
Public Function FindAndReplace()
 
Dim myStoryRange As Range
 
TFind_FR = "Département de l'éducation, de la culture et du sport"
TReplace_FR = "Département de la formation et de la sécurité"
 
TFind_DE = "Departement für Erziehung, Kultur und Sport"
TReplace_DE = "Departement für Bildung und Sicherheit"
 
'First search the main document using the Selection and replace french text
 With Selection.Find
    .Text = TFind_FR
    .Replacement.Text = TReplace_FR
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
 End With
 
 'Then search the main document using the Selection and replace german text
 With Selection.Find
    .Text = TFind_DE
    .Replacement.Text = TReplace_DE
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
 End With
 
'Now search all other stories using Ranges
For Each myStoryRange In ActiveDocument.StoryRanges
   If myStoryRange.StoryType <> wdMainTextStory Then
        With myStoryRange.Find
            .Text = TFind_FR
            .Replacement.Text = TReplace_FR
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
        With myStoryRange.Find
            .Text = TFind_DE
            .Replacement.Text = TReplace_DE
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
        Do While Not (myStoryRange.NextStoryRange Is Nothing)
           Set myStoryRange = myStoryRange.NextStoryRange
            With myStoryRange.Find
                .Text = TFind_FR
                .Replacement.Text = TReplace_FR
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
            With myStoryRange.Find
                .Text = TFind_DE
                .Replacement.Text = TReplace_DE
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
        Loop
    End If
Next myStoryRange
End Function