|
|
YOU ARE NOW AT THE
FREE MACROS PAGE
Copyright © 2005 by F. Thomas, all rights reserved unless otherwise granted.
You and anyone may freely copy and use the herein presented macros.
You may also distribute the macros freely but not commercially.
Animations herein are Copyrighted © 2005 by F. Thomas,
all rights reserved unless otherwise granted.
808
ATTENTION:
DO NOT CLOSE SPACES BETWEEN WORDS OR CHARACTERS THAT YOU THINK SHOULD BE JOINED TOGETHER IN THE FOLLOWING MACROS. THEY ARE ARRANGED THAT WAY TO FILL MESSAGE BOXES PROPERLY.
DISCLAIMER CONCERNING THE FOLLOWING MACROS: The following macros for Microsoft Word 97+ are viruse-free and can be reviewed now or anytime before using them.
I and anyone I know or have known personally will not be held responsible for your computer or any of its components.
It has been proven that computer problems are usually caused acccidentally by the owner of the computer, friends or relatives of the owner of the computer, acts of God, or because of electronically-transferred viruses.
AT YOUR OWN DISCRETION, SIMPLY COPY-PASTE THE FOLLOWING MACROS INTO YOUR (NewMacros) WINDOW, ASIGN YOUR SHORTCUT KEYS, AND YOU'RE READY TO EXPEDITE YOUR WRITING.
The following macros for Microsoft Word 97+ are viruse-free and can be reviewed now or anytime before using them.
For detailed instructions and use of these macros, CLICK THIS.
To return to the Home Page, Click Here.
If you are satisfied with the following macros, highlight and copy everything from the following "Sub ParagraphFinder()" to the very bottom of the page. The rest is up to you. THANK YOU FOR VISITING THIS SITE.
Sub ParagraphFinder()
'
' ParagraphFinder Macro
' Macro installed today's date 00/00/00/ by your name
'
Dim Xpara As Paragraph
Dim rng As Range
Set rng = Selection.Range
rng.Start = Selection.Range.Start
rng.End = ActiveDocument.Content.End - 1
Find1 = InputBox("T Y P E Y O U R F I R S T W O R D . T O C O N T I N U E, P R E S S E N T E R, O R C L I C K O K . T O E X I T, P R E S S >E S C A P E< K E Y, O R C L I C K C A N C E L .", "A L P H A")
If Find1 = "" Then
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
End If
Find2 = InputBox("T Y P E Y O U R S E C O N D W O R D. T H E N, T O C O N T I N U E, P R E S S E N T E R, O R C L I C K O K . O R, T O E X I T, P R E S S >E S C A P E< K E Y, O R C L I C K C A N C E L .", "A N D")
If Find2 = "" Then
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
End If
Find3 = InputBox("T Y P E Y O U R T H I R D W O R D . P R E S S E N T E R T O S E A R C H F O R P A R A G R A P H . O R, P R E S S S P A C E B A R O N C E, P R E S S E N T E R, A N D A T W O-W O R D ( P A R A G R A P H S E A R C H ) W I L L O C C U R . T O E X I T, P R E S S >E S C A P E< K E Y O R C L I C K C A N C E L .", "O M E G A")
If Find3 = "" Then
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
Else
If response = Find3InputBox = " " Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
End If
End If
For Each Xpara In rng.Paragraphs
current_para = Xpara.Range
res1 = InStr(1, current_para, Find1, vbTextCompare)
res2 = InStr(1, current_para, Find2, vbTextCompare)
res3 = InStr(1, current_para, Find3, vbTextCompare)
If res1 <> 0 And res2 <> 0 And res3 <> 0 Or res1 <> Null And res2 <> Null And res3 <> Null Then
Xpara.Range.Select
response = MsgBox("T H E P A R A G R A P H I S F O U N D ! P R E S S >E N T E R< K E Y T O C O N T I N U E . T O C L O S E O U T O F T H I S M E S S A G E B O X , C L I C K O N N O, O R P R E S S >E N T E R< T O M A K E C H O I C E I N N E X T M E S S A G E B O X .", vbYesNo, "C O N T I N U E ?")
End If
If response = vbNo Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
End If
Next
response = MsgBox("S E A R C H I S F I N I S H E D. P R E S S E N T E R K E Y T O R E S U M E Y O U R W O R K. I F Y O U F E E L T H A T T H E P A R A G R A P H F I N D E R M A D E A N E R R O R, A T T E M P T T H E S A M E F I N D A G A I N, B U T D O U B L E-C H E C K Y O U R S P E L L I N G.", vbYesNo, "S E A R C H I S F I N I S H E D")
If response = vbNo Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
End If
If response = vbYes Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
ActiveWindow.ActivePane.SmallScroll up:=6
Exit Sub
Else
End If
End Sub
Sub SaveInTwoFolders()
'
' SaveInTwoFolders Macro
' Macro installed today's date 00/00/00/ by your name
'
ChangeFileOpenDirectory "C:\Folder Number One\"
ActiveDocument.SaveAs FileName:=ActiveDocument.Name, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ChangeFileOpenDirectory "C:\Folder Number Two\"
ActiveDocument.SaveAs FileName:=ActiveDocument.Name, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
End Sub
Sub GeneralFindUp()
'
' GeneralFindUp Macro
' Macro installed today's date 00/00/00/ by your name
'
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
x$ = Selection()
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.SmallScroll up:=6
End Sub
Sub GeneralFindDown()
'
' GeneralFindDown Macro
' Macro installed today's date 00/00/00/ by your name
'
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
x$ = Selection()
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.SmallScroll up:=8
End Sub
Sub YouHighlightFindUp()
'
' YouHighlightFindUp Macro
' Macro installed today's date 00/00/00/ by your name
' SELECTS TEXT, AND TEXT REMAINS HIGHLIGHTED
x$ = Selection()
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.Execute
ActiveWindow.ActivePane.SmallScroll up:=6
End Sub
Sub YouHighlightFindDown()
'
' YouHighlightFindDown Macro
' Macro installed today's date 00/00/00/ by your name
' SELECTS TEXT, AND TEXT REMAINS HIGHLIGHTED
x$ = Selection()
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
ActiveWindow.ActivePane.SmallScroll up:=8
End Sub
Sub FindWholeWordUp()
' SELECTS TEXT FOR WHOLE-WORD-FIND, BUT TEXT DOES NOT REMAIN HIGHLIGHTED
' FindWholeWordUp Macro
' Macro installed today's date 00/00/00/ by your name
'
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
x$ = Selection
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Forward = False
.Wrap = wdFindAsk
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.SmallScroll down:=-4
Selection.EscapeKey
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Forward = False
.Wrap = wdFindAsk
ActiveWindow.ActivePane.SmallScroll up:=4
End With
End Sub
Sub FindWholeWordDown()
'SELECTS TEXT FOR WHOLE-WORD-FIND, BUT TEXT DOES NOT REMAIN HIGHLIGHTED
' FindWholeWordDown Macro
' Macro installed today's date 00/00/00/ by your name
'
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
x$ = Selection()
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=28
Selection.Find.ClearFormatting
With Selection.Find
.Text = x$
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.SmallScroll up:=8
End With
End Sub
Sub AutoThessaurus()
'
' AutoThessaurus Macro
' Macro installed today's date 00/00/00/ by your name
'
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=34
Selection.MoveDown Unit:=wdLine, Count:=6
Selection.MoveRight Unit:=wdWord, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Range.CheckSynonyms
Selection.MoveDown Unit:=wdLine, Count:=28
Selection.MoveUp Unit:=wdLine, Count:=36
Selection.MoveDown Unit:=wdLine, Count:=8
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Words(1).Select
Selection.Copy
Selection.Paste
Selection.Paste
Selection.Paste
Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend
Selection.TypeBackspace
Application.GoBack
Application.GoBack
Application.GoBack
Application.GoBack
Selection.MoveLeft Unit:=wdCharacter, Count:=1
End Sub