Attribute VB_Name = "VSReplace"
'bolay.co 2013
'Sylvain Bolay
'Last update: may 14, 2013
 
Public Sub VSReplace()
    Dim Directory As String
    Dim FType As String
    Dim FName As String
 
    Dim colFiles As New Collection
    RecursiveDir colFiles, "C:\VS", "*.doc", True
 
    FType = "*.doc"
 
 
    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
 
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
 
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
 
Public Function FindAndReplace()
 
Dim myStoryRange As Range
 
'First search the main document using the Selection and replace french text
 With Selection.Find
    .Text = "DÈpartement de l'Èducation, de la culture et du sport"
    .Replacement.Text = "DÈpartement de la formation et de la sÈcuritÈ"
    .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 = "Departement f¸r Erziehung, Kultur und Sport"
    .Replacement.Text = "Departement f¸r Bildung und Sicherheit"
    .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 = "DÈpartement de l'Èducation, de la culture et du sport"
            .Replacement.Text = "DÈpartement de la formation et de la sÈcuritÈ"
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
        With myStoryRange.Find
            .Text = "Departement f¸r Erziehung, Kultur und Sport"
            .Replacement.Text = "Departement f¸r Bildung und Sicherheit"
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
        Do While Not (myStoryRange.NextStoryRange Is Nothing)
           Set myStoryRange = myStoryRange.NextStoryRange
            With myStoryRange.Find
                .Text = "DÈpartement de l'Èducation, de la culture et du sport"
                .Replacement.Text = "DÈpartement de la formation et de la sÈcuritÈ"
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
            With myStoryRange.Find
                .Text = "Departement f¸r Erziehung, Kultur und Sport"
                .Replacement.Text = "Departement f¸r Bildung und Sicherheit"
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
        Loop
    End If
Next myStoryRange
End Function