Convert Hyperlinks To Proper Case

I create small files "TableOfContents" for use in my web pages.

By mis-adventure I often enough end up with hyperlinks in a mish-mash of cases.

I'd like all the hyperlinks to conform to a consistent standard.

Sub ConvertHyperlinksToProperCase()
    Dim HLNK As Hyperlink
    For Each HLNK In ActiveDocument.Hyperlinks
        With HLNK
            Dim strTextToDisplay As String
            strTextToDisplay = .TextToDisplay
            .TextToDisplay = StrConv(strTextToDisplay, vbProperCase)
        End With
    Next HLNK
End Sub

This little macro does that.

Note that it processes EVERY hyperlink in the current document, which is fine for me.

If you wanted it to operate only on a selected area you could change one line to read

    For Each HLNK In Selection.Hyperlinks

Quick Keys Quickies

We’ve all faced the problem of making a simple change to a series of paragraphs in a document, or inserting some choice item in each cell of a table, cases where Microsoft Word’s Edit-replace just can’t get the job done.

The mantra is “If it’s boring and repetitive, WRITE A MACRO”, but who has time to catalogue a vast array of macros which, having been used once, can be discarded?

The solution lies in recording a macro and assigning it to a fixed shortcut key combination, and to ease your transition into this amazing world, I’ve recorded a three-minute video which you can see through YouTube, or in higher definition (and longer download time) from my video collection.

I’ll spell out the keyboard sequences you need in the table below; you may want to print it out for future reference.

In the table below I suggest you use Ctrl-Shift-K as your shortcut key combination; it is not assigned to any special command in Microsoft Word, and is easy to remember.

I’ve used “{Your keyboard sequence}” to represent whatever keystrokes you require to perform your action one time. You will, of course, merely use the keyboard to perform your action one time.

Keyboard sequence	Full command
Alt-T, M, R	Choose Tools, Macro, Record
Alt-K, Ctrl-Shift-K, Enter, Enter	Choose Keyboard, Ctrl-Shift-K as the shortcut key combination, Assign, Close.
{Your keyboard sequence}	Here is where you will use the keyboard to perform the action, one time, that you want to assign to Ctrl-Shift-K.
Alt-T, M, R	Choose Tools, Macro, stop Recording.<= /p>

That’s it!

Position your cursor at the start of the text to be modified, hold down both the Ctrl and Shift keys, and tap the letter “K” repeatedly.

Here’s a full example of my assigning to Ctrl-Shift-K a macro that will insert alternate sequence fields at the head of a set of paragraphs.

Keyboard sequence	Full command
Alt-T, M, R	Choose Tools, Macro, Record
Alt-K, Ctrl-Shift-K, Enter, Enter	Choose Keyboard, Ctrl-Shift-K as the shortcut key combination, Assign, Close.
(, Ctrl-F9,seq,,question,, ,),	This inserts a sequence field “question”, surrounded by parentheses, with a space between the closing parenthesis and the paragraph text.
Ctrl-Down-Arrow	This moves to the next paragraph
(, Ctrl-F9,seq,,answer,, ,),	This inserts a sequence field “answer”, surrounded by parentheses, with a space between the closing parenthesis and the paragraph text.
Ctrl-Down-Arrow	This moves to the next paragraph
Alt-T, M, R	Choose Tools, Macro, stop Recording.

Detect Duplicate words in sentences

This little macro detects duplicated words in sentences.
unlike Microsoft Word's grammar/spell checker which merely identifies consecutive duplicate words, this macro (and associated function) marks in RED second and subsequent occurrences of words in each sentence.
A short list of noise words is provided as a string constant; we don't mind those words being repeated.

Public Const strcIgnoreWords As String = vbTab & "and" & vbTab & "on" & vbTab & "the" & vbTab
Sub DuplicateWordsInSentences()
  Dim prg As Paragraph
  For Each prg In ActiveDocument.Paragraphs
      Dim snt As Range
      For Each snt In prg.Range.Sentences
          Call FindDupInSentence(snt)
      Next snt
  Next prg
End Sub
Function FindDupInSentence(snt As Range)
  Dim strAllWords As String
  strAllWords = vbTab
  Dim wd As Range
  For Each wd In snt.Words
      Dim strWd As String
      strWd = Trim(wd.Text)
      If Len(strWd) > 1 Then
          If InStr(1, strcIgnoreWords, vbTab & strWd & vbTab) > 0 Then ' we ignore this word
          Else
              If InStr(1, strAllWords, vbTab & strWd & vbTab) > 0 Then
                  wd.Font.Color = wdColorRed
              Else
                  strAllWords = strAllWords & strWd & vbTab
              End If
          End If
      Else ' we ignore words of length 1 character
      End If
  Next wd
End Function

File Diversion

Your new system came in today, and while you are all free to read Word documents from the old server, you are all supposed to save files to the new server on drive J:.
Here's some stripped-down proof-of-concept code:

Public Const strcNewDrive As String = "J:"
Sub FileSave()
    MsgBox "FileSave"
    If Len(ActiveDocument.Path) = 0 Then ' not previously saved
        Call SaveAsDialog(strcNewDrive, ActiveDocument.Name)
    Else
        If UCase(Left(ActiveDocument.Path, 2)) = strcNewDrive Then  ' User is logged on to th drive
            ActiveDocument.Save
        Else
            Call SaveAsDialog(strcNewDrive, ActiveDocument.Name)
        End If
    End If
End Sub
Sub FileSaveAs()
    MsgBox "FileSaveAs"
    Call SaveAsDialog(strcNewDrive, ActiveDocument.Name)
End Sub
Function SaveAsDialog(strDrive As String, strName As String)
    With Application.Dialogs(wdDialogFileSaveAs)
        .Name = strDrive & "\" & strName
        .Format = wdFormatDocument
        .Show
    End With
End Function

Rebuild your Active Document

Your document is corrupt, or it is so heavily edited that it is behaving badly.
Use the little macro "RebuildActiveDocument" to grab all your text, unformatted, and rebuild the document.
CAUTION: make a copy of your document using Windows Explorer before running this macro.

Sub RebuildActiveDocument()

    ' Get the name of the source ActiveDocumentument

    Dim strFilename As String

    strFilename = ActiveDocument.FullName

    ' Get the stoty-content of the ActiveDocumentument

    Dim strStoryContent As String

    Dim lng As Long

    For lng = 1 To ActiveDocument.StoryRanges.Count

        strStoryContent = strStoryContent & ActiveDocument.StoryRanges(lng).Text

    Next lng

    ' Close the ActiveDocumentument WITHOUT saving changes

    ActiveDocument.Close (wdDoNotSaveChanges)

    ' Create a new ActiveDocumentument

    Documents.Add

    ' Insert the text file

    Selection.TypeText (strStoryContent)

    ' Save the ActiveDocumentument with the original name

    ActiveDocument.SaveAs (strFilename)

End Sub

Print View, Whole page, All documents

From time to time I find myself reviewing or updating a set of a dozen or so documents.

I like to see them in a consistent manner.

Perhaps they are a set of flyers, and I want to make sure that the layout above-the-fold is identical.

This little macro loops through all open documents, moves the cursor to the top of the document, then chooses Print View (WYSIWYG, almost) and a whole-page on the screen.

Sub PrintViewAll()

    Dim doc As Document

    For Each doc In Application.Documents

        doc.Activate

        Selection.HomeKey Unit:=wdStory

        ActiveWindow.View.Type = wdPrintView

        ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage

        Application.WindowState = wdWindowStateMaximize\

    Next doc

End Sub

P.S. If you'd rather be left at the foot of the documents, to append new text, use:-

Selection.EndKey Unit:=wdStory

P.P.S. If you'd rather be left in Normal view, use:

ActiveWindow.View.Type = wdNormalView

File,Close (No Save)

I'm feeling guilty about the length of the previous post.
I hope you'll accept this token of remorse.

We use Ctrl-F4 to close a document, and of course if the contents of the document have changed we get to answer the skill-testing question "Do you want to save?".
Oftentimes we know in advance that we don't want the changes. Perhaps we have been experimenting with the document and want to discard all changes before we accidentally overwrite the good version.

Closing a File (document) without saving changes is a one-liner, as shown below.

For extra utility you may want to assign an unused shortcut key combination to this macro.

Sub FileCloseNoSave()

    ActiveDocument.Close (wdDoNotSaveChanges)

End Sub

Mark Duplicated Words

If you'd like an easy way to improve your writing style, try this lengthy-looking macro and function.
It examines each sentence in your document looking for repeated words.
A string "strDismiss" is set up to avoid reporting words which I think are allowed to be repeated.
repeated words are flagged with Microsoft Word's character style "Strong", so you may want to modify that in your Normal.dot to be bright pink, 16 point, or whatever.
Don't forget that you can clear all local formatting with Ctrl-A followed by Ctrl-Space.

Public strDismiss As String

Sub MarkDuplicatedWords()

    strDismiss = vbTab & "for" & vbTab & "and" & vbTab & "that" & vbTab & "," & vbTab & "." & vbTab & "to" & vbTab

    strDismiss = strDismiss & "http" & vbTab & "://" & vbTab & "www" & vbTab & "com" & vbTab & "/" & vbTab & "the" & vbTab

    strDismiss = strDismiss & "a" & vbTab & "of" & vbTab & "www" & vbTab & "com" & vbTab & "/" & vbTab & "the" & vbTab

    strDismiss = strDismiss & """" & vbTab & "of" & vbTab & "www" & vbTab & "com" & vbTab & "/" & vbTab & "the" & vbTab

    Dim prg As Paragraph

    For Each prg In ActiveDocument.Paragraphs

        Dim snt As Range

        For Each snt In prg.Range.Sentences

            If lngCountDuplicatedWords(snt, strDismiss, ActiveDocument.Styles("Strong")) > 0 Then

            Else

            End If

        Next snt

    Next prg

End Sub

Function lngCountDuplicatedWords(rng As Range, strDismiss As String, sty As Style)

    Dim lngResult As Long

    Dim strSentence As String

    strSentence = vbTab

    Dim wd As Range

    For Each wd In rng.Words

        Dim strWord As String

        strWord = Trim(wd.Text)

        If InStr(1, strDismiss, vbTab & strWord & vbTab) > 0 Then ' we can ignore this word

        Else

            If InStr(1, strSentence, vbTab & strWord & vbTab) > 0 Then

                lngResult = lngResult + 1

                wd.Style = sty

            Else

                strSentence = strSentence & strWord & vbTab

            End If

        End If

    Next wd

    lngCountDuplicatedWords = lngResult

End Function

ToggleShowAll

I assign this cute trick to the Shift-Ctrl-8 keyboard shortcut.
It flip-flops between showing everything that's going on in my document, to showing nothing but pristine text and graphics.

Public Sub ToggleShowAll()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Function:   ToggleShowAll
    '''
    ''' Comments:   Use the current "Show Fields" setting (True or False) to toggle all visibility settings.
    '''
    ''' Arguments:  None.
    '''
    ''' Returns:    None
    '''
    ''' Date        Developer       Action
    ''' --------------------------------------------------------------------------
    ''' 2006/03/21  Chris Greaves   Created
    '''
    ''' The setting ShowFieldCodes  will be used to control the settings of  ShowFieldCodes, ShowAll , ShowFieldCodes , ShowHiddenText , ShowTabs , ShowSpaces , ShowParagraphs and ShowBookmarks.
    ''' All flags will be set to the opposite of the current setting of ShowFieldCodes.
    ''' If ShowFieldCodes is ON, all flags will be set OFF.
    ''' If ShowFieldCodes is OFF, all flags will be set ON.
    ''' The new setting will be saved as the key "Show All" in the Application Environment file.
    If Documents.Count > 0 Then
        Dim boolSet As Boolean
        boolSet = Not ActiveWindow.View.ShowFieldCodes
        With ActiveWindow.View
            .ShowAll = boolSet
            .ShowFieldCodes = boolSet
            .ShowHiddenText = boolSet
            .ShowTabs = boolSet
            .ShowSpaces = boolSet
            .ShowParagraphs = boolSet
            .ShowBookmarks = boolSet
        End With
        Dim strSet As String
        If boolSet Then
            strSet = "Y"
        Else
            strSet = "N"
        End If
    Else
    End If
End Sub

Close All But Active

From time to time I find that I have opened a slew of documents, just to help me understand the one document I'm working on.
In this case I want to violate my Golden Rule of "Never Close, never Minimize", and close all open documents EXCEPT THE ACTIVE DOCUMENT without saving a single one; discard all recent changes.
This little macro does the trick.

Public Sub CloseAllButActive()
    ''' Close all open documents EXCEPT THE ACTIVE DOCUMENT without saving a single one; discard all recent changes.
    If Documents.Count > 0 Then
        Dim docSave As Document
        Set docSave = ActiveDocument
        Dim doc As Document
        For Each doc In Application.Documents
            If doc <> docSave Then
                doc.Close savechanges:=wdDoNotSaveChanges
            Else
            End If
        Next doc
    Else ' nothing to do
    End If
End Sub

Jump To Document Folder

You've just saved your file, or you are wondering about another file in the same folder, so you need to open Windows Explorer and work your way through the trees to your folder.
That would be Alt-Tab to Explorer (or Start, Run, explorer.exe), click, double-click, click etc.
Right?
Wrong!
Use the little macro below

Public Sub JumpToDocumentFolder()
    ''' Launch Windows Explorer into the current document's folder.
    Call Shell("explorer.exe /e," & ActiveDocument.Path, vbMaximizedFocus)
End Sub

Delete All Paragraphs This Style

From time to time I have occasion to remove globs of text from a document leaving bits behind.
For example, I might want to delete all 'Normal" styled paragraphs and leave only the 'Heading " styled paragraphs behind.
This macro does the trick, regardless of the styles in use!

Sub DeleteAllParagraphsThisStyle()
    ''' Place the text cursor in a paragraph, run the macro.
    ''' All paragraphs in that (selected) style will be removed from the document.
    Dim strStyleName As String
    strStyleName = Selection.Paragraphs(1).Range.Style
    Dim lng As Long
    For lng = ActiveDocument.Paragraphs.Count To 1 Step -1
        If ActiveDocument.Paragraphs(lng).Style = strStyleName Then
            ActiveDocument.Paragraphs(lng).Range.Delete
        Else
        End If
    Next lng
End Sub

CloseAllTakeNoPrisoners

Although as a rule I "Never Close, Never Minimize", I confess to times when I have literally dozens of documents left open after a failed attempt to batch-process a folder.
At that time I like to fix the problem and start with a clean slate.
The little macro below shrugs and wipes my slate clean!

Public Sub CloseAllTakeNoPrisoners()
    ''' Close all open documents without saving a single one; discard all recent changes.
    Dim doc As Document
    For Each doc In Application.Documents
        doc.Close savechanges:=wdDoNotSaveChanges
    Next doc
    If Documents.Count > 0 Then
        Documents.Close savechanges:=wdDoNotSaveChanges
    Else
    End If
End Sub

Close without saving changes

Do you ever get partway through changing a Word document and think "Oh this is totally silly"?
Here's the macro to shut down what you're doing and abandon all changes.
Effortlessly.
Without getting confused over Word's skill-testing questions late at night.

Public Sub CloseNoSave()
   ''' Close the current document without saving it
   ActiveDocument.Close (wdDoNotSaveChanges)
End Sub

Revert to Saved File

Choosing Edit, Undo (or better yet, using Ctrl-Z) is all very well for a few changes, but a professional saves their work every time a significant change has been made, or every time they embark on a risky manoeuvre.
Some of us save our work before we pick up the phone, or as we hear a colleague approaching.
That means that our saved file is the best source of recovering from a failed experiment.

Public Sub FileRevertToSaved()
    If Len(ActiveDocument.Path) = 0 Then
        MsgBox "You can not revert to an unsaved file."
    Else
        If MsgBox("Are you sure that you want to abandon your current work?", vbYesNo) = vbNo Then
        Else
            Documents.Open FileName:=ActiveDocument.FullName, revert:=True
        End If
    End If
End Sub

Signature at foot of page

The documents bear a signature on page 2 of a 4-page document, and we wanted to maximize the amount of white space before the signature, by pushing the signature to the foot of the signature page.
Place the cursor in the signature (2nd-last paragraph of page 2) and run the macro SpaceBefore.

Sub SpaceBefore()
' Increase paragraph-spacing-before the first Paragraph of the selection to fill up the current page of the document
Dim prg As Paragraph
Set prg = Selection.Paragraphs(1)
Dim lngSpaceAbove As Long
lngSpaceAbove = prg.SpaceBefore
Dim lngPages As Long
lngPages = prg.Parent.Range.Information(wdActiveEndPageNumber)
While lngPages = prg.Parent.Range.Information(wdActiveEndPageNumber)
   lngSpaceAbove = lngSpaceAbove + 1
   prg.SpaceBefore = lngSpaceAbove
Wend
prg.SpaceBefore = lngSpaceAbove - 1
End Sub

Minutes later I decided to add some text to the document, pushing the signature paragraph over to page 3, so ...

Place the cursor in the signature (2nd-last paragraph of page 2) and run the macro DecreaseSpaceBefore.

Sub DecreaseSpaceBefore()
' Decrease paragraph-spacing-before the first Paragraph of the selection to pull the current page up by one page.
' Use this after inserting extra text after running "IncreaseSpaceBefore"
Dim prg As Paragraph
Set prg = Selection.Paragraphs(1)
Dim lngSpaceAbove As Long
lngSpaceAbove = prg.SpaceBefore
Dim lngPages As Long
lngPages = prg.Parent.Range.Information(wdActiveEndPageNumber)
While lngPages = prg.Parent.Range.Information(wdActiveEndPageNumber)
   lngSpaceAbove = lngSpaceAbove - 1
   prg.SpaceBefore = lngSpaceAbove
Wend
End Sub

Keep with before

Don't get me started on Microsoft ...
I have a simple document with "Heading 1", "Heading 2" and "Heading 3" styled paragraphs, and within each heading, text in "Body Text" style.
Sadly some of the Body Text material splits across a page, and I'd rather have all the Body text on the same page as its immediate parent "Heading".
Office 2003 hasn't had "Keep With Before" for at least the last 8 years, so I wrote the attached.
Use:
Place the text cursor anywhere in any paragraph of YOUR text style; it doesn't have to be Body Text.
Run the macro TESTKeepWithBeforeSelection.
Method:
I'm using Selection so you can enjoy the blinking lights.
I leave your original selection in place when I'm done.
I use the style of the FIRST paragraph in your selection as my guiding light.
I turn OFF KeepWithNext and turn ON KeepTogether in every paragraph in the document.
Then for each paragraph in your chosen style, I backup one paragraph to the preceding paragraph and turn ON KeepWithNext.
This seems to work for me.

Function KeepWithBeforeSelection(strStyle As String)
   Selection.HomeKey Unit:=wdStory
   Selection.Find.ClearFormatting
   Selection.Find.Style = ActiveDocument.Styles(strStyle)
   With Selection.Find
       .Text = "^p"
       .Replacement.Text = ""
       .Forward = True
       .Wrap = wdFindContinue
       .Format = True
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
   End With
   While Selection.Find.Execute
       Selection.MoveUp Unit:=wdParagraph, Count:=2
       Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
       With Selection.ParagraphFormat
           .KeepWithNext = True
       End With
       Selection.MoveDown Unit:=wdParagraph, Count:=2
   Wend
End Function
Sub TESTKeepWithBeforeSelection()
   Dim rng As Range
   Set rng = Selection.Range
   Dim strStyle As String
   strStyle = Selection.Paragraphs(1).Range.Style.NameLocal
   Selection.WholeStory
   With Selection.ParagraphFormat
       .KeepWithNext = False
       .KeepTogether = True
   End With
   Selection.HomeKey Unit:=wdStory
   Call KeepWithBeforeSelection(strStyle)
   rng.Select
End Sub