operating_systems:microsoft:vsreplace
This is an old revision of the document!
VSReplace
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
operating_systems/microsoft/vsreplace.1368544565.txt.gz · Last modified: 2013/05/14 15:16 by sbolay