VBA Word Find & Replace Macro / Need to convert to VB Sc

[montanan]

I think this code will be useful to any of us who do merges into Microsoft Word using Macro Scheduler. What is really nice about this is that it does replaces in the Header and Footer, which the normal functions in Word do not do.

I found the following code...

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim pFindTxt As String
Dim pReplaceTxt As String
Dim lngJunk As Long
Dim oShp As Shape
pFindTxt = InputBox("Enter the text that you want to find." _
, "FIND")
If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
TryAgain:
pReplaceTxt = InputBox("Enter the replacement.", "REPLACE")
If pReplaceTxt = "" Then
If MsgBox("Do you just want to delete the found text?", _
vbYesNoCancel) = vbNo Then
GoTo TryAgain
ElseIf vbCancel Then
MsgBox "Cancelled by User."
Exit Sub
End If
End If
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub

... and I am trying to convert it to VB Script so that I can run it from within a Macro Scheduler program.

If one or more of you VB Script gurus would show me how to do this, I would sure appreciate it!

-Richard

[Marcus Tettmar]

This should get you started:
http://www.mjtnet.com/blog/2008/04/28/c ... -vbscript/

[Marcus Tettmar]

Here you go:

Code: Select all

/*
Function to search/replace text in Word document.

Parameters:
  docfile: full path and filename of running document
  textToFind: the text to search for
  replacementText: the replacement text - can be empty string to "delete" the found text

Note that the specified Word document must be open and running Word
because this uses COM to attach to the existing instance of Word.
*/

VBSTART
Sub FindReplaceAnywhere(docfile,textToFind,replacementText)
  Dim ActiveDocument

  Set ActiveDocument = GetObject(docfile)

  Dim rngStory
  Dim pFindTxt
  Dim pReplaceTxt
  Dim lngJunk
  Dim oShp
  pFindTxt = textToFind
  If pFindTxt = "" Then
    Exit Sub
  End If

  pReplaceTxt = replacementText

  'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
      On Error Resume Next
      Select Case rngStory.StoryType
      Case 6, 7, 8, 9, 10, 11
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If oShp.TextFrame.HasText Then
              SearchAndReplaceInStory oShp.TextFrame.TextRange, pFindTxt, pReplaceTxt
            End If
          Next
        End If
      Case Else
        'Do Nothing
      End Select
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
End Sub

Sub SearchAndReplaceInStory(ByVal rngStory, ByVal strSearch, ByVal strReplace)
  Dim wdFindContinue, wdReplaceAll
  wdFindContinue = 1
  wdReplaceAll = 2

  With rngStory.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = strSearch
    .Replacement.Text = strReplace
    .Wrap = wdFindContinue
    .Execute ,,,,,,,,,,wdReplaceAll
  End With
End Sub

VBEND

//Use it thus:
Let>myDoc=C:\mypath\subfolder\mydocument.doc
VBRun>FindReplaceAnywhere,myDoc,Richard,Marcus

I have removed the Input boxes which ask for the text to find and the replacement text and have instead made those parameters to the subroutine.

Note that the Word document MUST already be open and running in Word as this attaches to the Word instance using COM

Caveat: I have tested this successfully in Word 2013. I have NOT tested it in any other version.

[montanan]

Thank you so very much for helping with this, Marcus.

I have tested it in Word 2010 and it works fine.

Managing the find and replace values as variables is exactly what I was hoping to accomplish.

It will be in use in a solution for our sales team very soon!

-Richard

[armsys]

Let>myDoc=C:\mypath\subfolder\mydocument.doc
VBRun>FindReplaceAnywhere,myDoc,Richard,Marcus[/code]
Note that the Word document MUST already be open and running in Word as this attaches to the Word instance using COM
Caveat: I have tested this successfully in Word 2013. I have NOT tested it in any other version.

Marcus, thanks for investing time in creating a useful MS/VBS code benefitting to all Macro Scheduler users. Direct calling VBA from MS is mostly theorectical and had been discussed cursorily so far. This is the first live working MS script. With this sample script, we can clone and expand all kinds of VBA functionalities inside MS. That's powerful and time-saving.
Please do post it to Macrus' Macro Blog as well.
Thanks, Marcus.

[armsys]

Thank you so very much for helping with this, Marcus.

Hi Richard,
Thanks for raising the question.

[armsys]

Marcus,
Previously I ran the following VBA inside Word without a glitch, of course. Now I don't know how to apply your solution above directly inside MS script.
Goal:
[1] Do multiple search & replace to the whole document;
[2] Apply various formats to the whole document;
[3] Copy the whole document into clipboard.

Code: Select all

Sub FR1()
' FR1 Macro
' Find & Replace #1
  Selection.WholeStory
  Selection.Delete Unit:=wdCharacter, Count:=1
  Selection.PasteAndFormat (wdFormatOriginalFormatting)
  Selection.WholeStory
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute FindText:="__._,_.___", ReplaceWith:="", MatchWildcards:=False, Replace:=wdReplaceAll
   End With
  Selection.WholeStory
  Selection.Font.Size = 12
  Selection.Font.Name = "Tahoma"
  With Selection.ParagraphFormat
    .LeftIndent = InchesToPoints(0)
    .RightIndent = InchesToPoints(0)
    .SpaceBefore = 0
    .SpaceBeforeAuto = False
    .SpaceAfter = 0
    .SpaceAfterAuto = False
    .LineSpacingRule = wdLineSpaceSingle
    .Alignment = wdAlignParagraphLeft
    .WidowControl = True
    .KeepWithNext = False
    .KeepTogether = False
    .PageBreakBefore = False
    .NoLineNumber = False
    .Hyphenation = True
    .FirstLineIndent = InchesToPoints(0)
    .OutlineLevel = wdOutlineLevelBodyText
    .CharacterUnitLeftIndent = 0
    .CharacterUnitRightIndent = 0
    .CharacterUnitFirstLineIndent = 0
    .LineUnitBefore = 0
    .LineUnitAfter = 0
    .MirrorIndents = False
    .TextboxTightWrap = wdTightNone
    .CollapsedByDefault = False
    .AutoAdjustRightIndent = True
    .DisableLineHeightGrid = False
    .WordWrap = True
    .BaseLineAlignment = wdBaselineAlignAuto
  End With
  Selection.ParagraphFormat.TabStops.ClearAll
  ActiveDocument.DefaultTabStop = InchesToPoints(0.2)
  'Selection.EndKey Unit:=wdStory
  Selection.WholeStory
  Selection.Copy
End Sub

I did try:
Dim ActiveDocument
Set ActiveDocument = GetObject(doc)
It doesn't seem to work.

Please help. Thanks.

[Marcus Tettmar]

There's a bit more to it than that. You need to define the constants and call the functions using parameter lists rather than names. Did you read the article I posted a link to in my first reply above where this is explained?

[armsys]

Marcus,
Please cease to be tormented by my VBScript issue.
It's already been elegantly resolved and perfectly runs for hours.
The entire credit belongs to HansV of Eileen's Lounge. See: http://www.eileenslounge.com/viewtopic.php?f=26&t=13858
I condense my working code as following for your pleasure viewing.
My actual code contains about 50+ simple/wildcard Find & Replace and 50+ font/paragraph Formattings.
The most chanlleging moving-heaven-and-earth efforts invovled the running of the Word VBA directly inside the Macro Scheduler script.
In a glance, as you may concur, the solution is surprisingly simple insofar as the integration of VBA/Macro and Macro Scheduler is concerned.
The key solution pivots upon the object:
Set doc = GetObject("C:\Temp\Temp.docx")
The rest are merely doc.this and doc.that as usual. No big deal.
I hope the following code can save other Macro Scheduler users insanely miserable hours.
Above all, this is probably the fastest script you can get from Macro Scheduler capable to handle hundreds of Microsoft Wod 2013 Find & Replace and Formattings in seconds.
Marcus, thanks for your kind assistance.
Marcus, thanks for your magnificent product.

Code: Select all

VBStart
Sub FR01()
  'Find & Replace #01
  Dim doc
  Set doc = GetObject("C:\Temp\Temp.docx")
  doc.Content.Delete
  doc.Content.Paste
  With doc.Content.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = 1
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    '.Execute "__._,_.___", , , False, , , , , , "", 2
    '.Execute "**** IMPORTANT PLEASE READ ****^pThis group is for the discussion between users only.^p", , , False, , , , , , "", 2
    .Execute "(\> ?){1,}", , , True , , , , , , "^p", 2
    .Execute "^u0182", , , False, , , , , , "", 2
    .Execute "(^13)([>][ ]@){1,}", , , True, , , , , , "^p", 2
    .Execute " {2,}", , , True, , , , , , " ", 2
    .Execute " ^p", , , False, , , , , , "^p", 2
  End With
  With doc.Content
    With .Font
      .Size = 12
      .Name = "Tahoma"
    End With
    With .ParagraphFormat
      .LeftIndent = 0
      .RightIndent = 0
      .SpaceBefore = 0
      .SpaceBeforeAuto = False
      .SpaceAfter = 0
      .SpaceAfterAuto = False
      .LineSpacingRule = 0
      .Alignment = 0
      .WidowControl = True
      .KeepWithNext = False
      .CharacterUnitRightIndent = 0
      .CharacterUnitFirstLineIndent = 0
      .LineUnitBefore = 0
      .LineUnitAfter = 0
      .MirrorIndents = False
      .TextboxTightWrap = 0
      .CollapsedByDefault = False
      .AutoAdjustRightIndent = True
      .DisableLineHeightGrid = False
      .WordWrap = True
      .HalfWidthPunctuationOnTopOfLine = False
      .HangingPunctuation = True
      .FarEastLineBreakControl = True
      .AddSpaceBetweenFarEastAndAlpha = True
      .AddSpaceBetweenFarEastAndDigit = True
      .BaselineAlignment = 4
      .TabStops.ClearAll
      doc.DefaultTabStop = 14.4
    End With
    .Copy
  End With
End Sub
VBEnd

// Voila...
VBRun>FR01