All In One

				
'**************************************
' Name: All In One
' Description:While working in real life, we need to have many macro's in ms-word or excel. Here is one of them. It's actually been created for our office purpose only by me. But iam sharing it with all my friends here at planetsource. 
We need to edit word docs. For that we need to do the following in a document:
N.B.-> Create a folder on desktop with the name Docedit. (You will need to do this only once!)
The macro will then - 
 
* Border all the tables inside the whole doc.
* Change part of footer name only.
* Justify the paragraphs of the whole doc.
* Remove all the smart tags.
* Remove spelling and grammer check option. (This will disable showing the RED and GREEN curvy lines).
* Search,highlight and underline predefined text inside the document.
* The folder that you created on desktop with the name Docedit - the macro will process al the word docs inside that and will make the changes,save the doc and close your files automatically.
' By: Arindam Ray
'
' Inputs:None.
'
' Returns:None.
'
' Side Effects:None.Please dont edit anything inside the LOOP of the macro without any prior knowledge, otherwise the macro will run until you press CTRL+ALT+DEL.
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=9535&lngWId=4'for details.'**************************************

Sub AllInOne()
 
' Macro created by Arindam Ray
 
myDirectory = "C:\Documents and Settings\Arindam.ZACKSRESEARCH\Desktop\testing"
ChangeFileOpenDirectory myDirectory
Dim CurrFile As String
CurrFile = Dir(myDirectory & "\*.doc")
Do While CurrFile <> ""
Documents.Open FileName:=CurrFile
With ActiveDocument.Content.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorPink
.Font.Underline = wdUnderlineWords
End With
.Execute FindText:="Punk, Ziegel", ReplaceWith:="", _
Format:=True, Replace:=wdReplaceAll
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorPink
.Font.Underline = wdUnderlineWords
End With
.Execute FindText:="( , )", ReplaceWith:="", _
Format:=True, Replace:=wdReplaceAll
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorPink
.Font.Underline = wdUnderlineWords
End With
.Execute FindText:="ThinkEquity", ReplaceWith:="", _
Format:=True, Replace:=wdReplaceAll
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorPink
.Font.Underline = wdUnderlineWords
End With
.Execute FindText:="( , , )", ReplaceWith:=" ", _
Format:=True, Replace:=wdReplaceAll
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorPink
.Font.Underline = wdUnderlineWords
End With
.Execute FindText:="( .)", ReplaceWith:=" ", _
Format:=True, Replace:=wdReplaceAll
End With
' Disable spelling checking.
Options.CheckSpellingAsYouType = False
ActiveDocument.ShowSpellingErrors = False
ActiveDocument.RemoveSmartTags
With ActiveDocument.Paragraphs
 ActiveDocument.Paragraphs.Alignment = wdAlignParagraphJustify
End With
 Dim rngStory As Word.Range
 Dim pFindTxt As String
 Dim pReplaceTxt As String
 Dim lngJunk As Long
 Dim oShp As Shape
 pFindTxt = "www.yahoomail.com"
 If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
 End If
TryAgain:
 pReplaceTxt = "www.yahoo.com"
 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
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
 
 For Each rngStory In ActiveDocument.StoryRanges
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
 End Select
 On Error GoTo 0
 Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
 Next
ActiveDocument.Close _
SaveChanges:=wdSaveChanges
CurrFile = Dir
Loop
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
 
Dim oTable As Table
Dim oBorderStyle As WdLineStyle
Dim oBorderWidth As WdLineWidth
Dim oBorderColor As WdColor
Dim n As Long 'used to count tables for message
Dim i As Long 'used with array
Dim oArray As Variant
oBorderStyle = wdLineStyleSingle
oBorderWidth = wdLineWidth050pt
oBorderColor = wdColorBlack
oArray = Array(wdBorderTop, _
wdBorderLeft, _
wdBorderBottom, _
wdBorderRight, _
wdBorderHorizontal, _
wdBorderVertical)
For Each oTable In ActiveDocument.Tables
n = n + 1
With oTable
For i = LBound(oArray) To UBound(oArray)
With .Borders(oArray(i))
.LineStyle = oBorderStyle
.Color = oBorderColor
End With
Next i
End With
Next oTable
End Sub