Attribute VB_Name = "AN_Macros"
'############################################################
'#
'#
'#      |*-----------------------------------*|
'#      ||         MS WORD MACROS            ||
'#      |*-----------------------------------*|
'#                      Last modified: 12/01/06
'#                 by Andrew Noske
'#           (http://www.andrewnoske.com/)
'#
'#
'# INSTRUCTIONS (HOW TO USE THESE MACROS):
'#
'#  1) Open MS Word, then go:
'#     Tools >> Macro >> Visual Basic Editor  (or press Alt+F11)
'#  2) On the right hand side, right click "Normal", then click:
'#     Insert >> Module.
'#  3) Cut-and-paste the entire text contents of this file into the
'#     new "module".
'#     *OR*    If you save this as a .bas file you can right
'#             click "Normal" and click "Inport File" and locate
'#             this file  (in place of steps 2 and 3)
'#  4) Minimize the Visual Basic window, and in Word go:
'#     Tools >> Macro >> Macros (or press Alt-F8)
'#  5) Here you can hopefully see new macros have been added.
'#  6) From this menu you can run them, edit them etc.... so
'#     have a play around, and see how they work.
'#
'#  Next time you want to use one of these Macros, press Alt-F8
'#  and double click the one you want.  :)
'#
'#
'# WHAT ARE MACROS:
'#
'#  Macros are little scripts written in Visual Basic, which you can
'#  record or write yourself to help automate repeative tasks in
'#  the common MS Office applications.
'#
'#  Macros are great, because, you'll often find yourself performing
'#  the same sequences of operations again and again in computing,
'#  and Macros can save you time, but letting you press a short-cut,
'#  then executing these steps for you.
'#
'#  Visual Basic is a babish language, and often won't work the way
'#  you want, but it's worth learning a BIT, just for the sake
'#  of learning how to use Macros. Macros can potentially save you
'#  HOURS and hours (expecially Excel Macros I've found), and I
'#  recommend all computer students learn a little about them.
'#  Identifying what task you should use macros for is half the challenge.
'#
'#
'# WHAT IS THIS FILE FOR:
'#
'#  This file contains some simple Macros for Microsoft Word
'#  I wrote for a few common tasks I've encountered: fixing e-mail
'#  formatting (because e-mail servers always screw up the spacing)
'#  and formatting of e-mails) and automatically changing the
'#  text colour of code comments (because I often print code
'#  and like it to pretty).
'#
'#  Even if you don't use these Macros they might help you understand
'#  how to write your own Macros (although usually it's easier
'#  to select the record Macro option) for all those common tasks
'#  you have to repeat.
'#
'############################################################





'############################################################
'# MACROS:
'############################################################

'============================================================
' MACROS FOR FIXING TEXT FROM/FOR E-MAILS:
'
'  When you send an e-mail most e-mail services (expecially web-based)
'  change your text by adding return characters where you don't want them,
'  adding ">"'s, and often causes problems/mistrepresenations if you
'  and-paste unicode characters into the text box. Following are three macros
'  which fix each of these three respective problems. To use them,
'  just cut-and-paste text from the e-mail (or wherever else) into Word,
'  run the appropriate macro(s) then cut-and-paste back into the e-mail
'  textbox (or whatever else you want to). Simple as pie.
'============================================================

'-------------------------------------------
Sub AN_EMAIL__Fix_formatting_of_forwarded_email()
'
' AN_EMAIL__Fix_formatting_of_forwarded_email Macro (by Andrew Noske 26/06/2004)
' Removes the ">" characters in the text (such as appear in a forwarded e-mail).
'
    Selection_ReplaceAll "> ", ""    '## DELETE ALL "> "'s
    Selection_ReplaceAll ">", ""    '## DELETE ALL ">"'s
    
End Sub

'-------------------------------------------
Sub AN_EMAIL__Fix_spaced_out_email_formatting()
'
' AN_EMAIL__Fix_spaced_out_email_formatting Macro (by Andrew Noske 26/06/2004)
' Helps fix/delete the numerous unnecessary (and out-of-place) return
' characters which occurs in e-mails especially forwarded e-mails).
'
    Selection_ReplaceAll Chr(13), "__#"                 'Removes all return characters and replaces them with "__#"
    Selection_ReplaceAll "__#__#", (Chr(13) & Chr(13))  'Replaces occurances of 2  "__#"'s with 2 return characters
    Selection_ReplaceAll "__#", " "                     'Replaces any remainin "__#"'s with a space
    
End Sub

'-------------------------------------------
Sub AN_EMAIL__Make_text_ASCII_safe()
'
' AN_EMAIL__Make_text_ASCII_safe Macro (by Andrew Noske 26/06/2004)
' Fixes the text typed into MS Word so it's ready to be cut and paste
' into an compose text-box (or other web textbox).
' It does this by replacing common characters that e-mail misrepresents
' or does not support or  (such as sloped quote marks, and
' "..." ellipses) with ASCII character equivalents.
' It's valueable for me because I type most of my e-mail in Word so that
' I can save an spell check them, but run this macro before I cut and paste
' it into my yahoo compose text box ready send.
'
    Dim numOcc As Integer
    
    Selection_ReplaceAll "…", "..."     '## REPLACE ALL "…"s (ELLIPSES) WITH "..."
    Selection_ReplaceAll Chr(150), "-"   '## REPLACE ALL LONG DASHES WITH NORMAL DASHES"
    
    'Selection_ReplaceAll Chr(145), Chr(39)     '|-- Not sure why, but for these methods the character autochanges back to
    'Selection_ReplaceAll Chr(146), Chr(39)     '|   what we don't what! - instead I have to delete and type it (see below)
    'Selection_ReplaceAll Chr(147), """"        '|
    'Selection_ReplaceAll Chr(148), """"        '|
    
    '## REPLACE ALL (LEFT-AND-RIGHT-FACING) SINGLE QUOTES WITH NORMAL QUOTE CHARACTER
    numOcc = StringFs_CountOccurancesInWholeDoc(Chr(145))
    For i = 1 To numOcc
        Selection_FindNext Chr(145)
        Selection.Delete
        Selection.TypeText Text:="'"
    Next i
    numOcc = StringFs_CountOccurancesInWholeDoc(Chr(146))
    For i = 1 To numOcc
        Selection_FindNext Chr(146)
        Selection.Delete
        Selection.TypeText Text:="'"
    Next i
    
    '## REPLACE ALL (LEFT-AND-RIGHT-FACING) DOUBLE QUOTES WITH NORMAL (FLAT) DOUBLE QUOTE CHARACTER
    numOcc = StringFs_CountOccurancesInWholeDoc(Chr(147))
    For i = 1 To numOcc
        Selection_FindNext Chr(147)
        Selection.Delete
        Selection.TypeText Text:=""""
    Next i
    numOcc = StringFs_CountOccurancesInWholeDoc(Chr(148))
    For i = 1 To numOcc
        Selection_FindNext Chr(148)
        Selection.Delete
        Selection.TypeText Text:=""""
    Next i
    
End Sub


'============================================================
' MACROS FOR PRINTING CODE:
'
'  Whenever I print out code for assignments I want it to look nice,
'  so I cut-and-paste it into word, change the text size, and then run
'  one (or two) of these macros to automatically change the text colour
'  of the code comments; thus making the code easier to read.
'============================================================


'-------------------------------------------
Sub AN_CODE__Change_selection_to_list_of_string_for_array()
'
' AN_CODE__Change_selection_to_list_of_string_for_array (by Andrew Noske 12/01/2006)
' Lets you make a selection of words seperated by return characters or spaces, and
' prints these out above in the format you'd expect of a an array of strings.
' eg: ' first second third_word  '   PRINTS: '  {"first", "second", "third_word"} '
'
    Dim arr As Variant
    Dim selStr, newStr, sepStr, repStr As String
    Dim numItems As Integer
    
    '## CHECK SELECTION HAS BEEN MADE:
    selStr = Selection.Text
    If (Len(selStr) <= 1) Then
        AlertMsg ("You must make a selection" & Chr(13) & Chr(13) & _
                  "Make a selection of words seperated by lines (return characters)" & Chr(13) & _
                  "or space and this will generate an array of strings above it.")
        Exit Sub
    End If
    
    '## DETERMINE WETHER TO USE SPACE OR RETURN AS "STRING SEPERATOR" CHARACTER
    sepStr = Chr(13)        ' character/string which seperates our strings (set to default to be a return character)
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    
    If (Mid(selStr, Len(selStr), 1) = sepStr) Then          'if last character is a return - remove it
        selStr = Mid(selStr, 1, Len(selStr) - 1)
    End If
    If StringFs_CountOccurances(selStr, sepStr) = 0 Then    'if only one line is selected: use space characters as "string seperator" instead
        sepStr = " "
        AlertMsg ("Single line selected: will seperate whitespaces")
    End If
    
    '## TURN SELECTION INTO STRING ARRAY-LIKE FORMAT:
    newStr = StringFs_MyReplace(selStr, sepStr, ",")        'replace all seperator characters with commas
    newStr = StringFs_MyReplace(newStr, " ", "")            'remove all spaces
    newStr = StringFs_MyReplace(newStr, ",", """, """)      'replace all commas with:   ","
    'newStr = StringFs_MyReplace(newStr, """"", ", ",")     'will remove "empty strings"
    
    newStr = """" + newStr
    If (Mid(newStr, Len(newStr) - 2, 3) = ", """) Then
        newStr = Mid(newStr, 1, (Len(newStr) - 3))
    End If
    If Not (Mid(selStr, Len(selStr), 1) = """") Then    'if last character is not '"' then add '"'
        newStr = newStr + """"
    End If
    
    numItems = StringFs_CountOccurances(newStr, ",") + 1
    Selection.TypeText (Chr(13) + Chr(13) + "{ " + newStr + " }" + Chr(13) + Chr(13))   'print final list
    
    AlertMsg (CStr(numItems) + " strings have been found")
    
End Sub


'-------------------------------------------
Sub AN_CODE__Make_all_exclamation_comments_red()
'
' AN_CODE__Make_all_exclamation_comments_red Macro (by Andrew Noske 26/06/2004)
' Finds all "!"'s and makes the "line" red from that point until the end of the line.
'
    Dim numComments As Integer
    numComments = Selection_ChangeColorOfLineComment("!", wdColorBlue)
    AlertMsg (numComments & " comments replaced")
    
End Sub

'-------------------------------------------
Sub AN_CODE__Make_all_double_backslash_comments_red()
'
' AN_CODE__Make_all_double_backslash_comments_red Macro (by Andrew Noske 26/06/2004)
' Finds all "//"'s and makes the "line" red from that point until the end of the line.
'
    Dim numComments As Integer
    numComments = Selection_ChangeColorOfLineComment("//", wdColorBlue)
    AlertMsg (numComments & " comments replaced")
    
End Sub

'-------------------------------------------
Sub AN_CODE__Make_backslash_star_comments_red()
'
' AN_CODE__Make_backslash_star_comments_red Macro (by Andrew Noske 26/06/2004)
' Makes all text between and including "/*" and "*/" comment tags red
' (these comments are common in C++ and Java).
'
    Dim numComments As Integer
    Dim beginFound
    
    numComments = StringFs_CountOccurancesInWholeDoc("/*")
    ActiveDocument.Bookmarks("\StartOfDoc").Select  ' move cursur to start of document
    
    beginFound = False
    For i = 1 To Document_NumCharacters
        
        If (beginFound = False) Then
        
            Selection.MoveRight Unit:=wdCharacter, Count:=1
            If Selection.Characters.First = "/" Then
                Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
                If Selection.Characters.Last = "*" Then     'if "/*" just found -> keep extending selection, but now searches for "*/"
                    beginFound = True
                End If
            End If
        
        Else
        
            Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            If Selection.Characters.Last = "*" Then
                Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                If Selection.Characters.Last = "/" Then     'if "*/" just found -> make selection red, put cursor at end of selection and look for another "/*"
                    Selection.Font.color = wdColorRed
                    Selection.MoveRight Unit:=wdCharacter, Count:=1
                    beginFound = False
                End If
            End If
        
        End If
    
    Next i
    
End Sub

'-------------------------------------------
Sub AN_CODE__Format_fortran_code()
'
' AN_CODE__Make_all_exclamation_comments_red Macro (by Andrew Noske 26/06/2004)
' Finds all "!"'s and makes the "line" red from that point until the end of the line.
'

    Dim rW1, rW2, rW3 As Variant
    Dim str As String
    
    rW1 = Array("for", "do", "enddo", "while", "if", "then", "else", "endif", "return")
    rW2 = Array("parameter", "int", "float", "double", "real")
    
    Selection_ChangeColorAllTheseWords rW1, wdColorBlue
    Selection_ChangeColorAllTheseWords rW2, wdColorRed
    
End Sub

'-------------------------------------------
Sub AN_CODE__Format_CPP_code()
'
' AN_CODE__Format_CPP_code Macro (by Andrew Noske 26/06/2004)
' Formats C++ syntax by applying appropriate colours to reserve words etc.
'
    
' UNCOMMON:         "asm", "auto", "register", "extern", "sizeof", "union", "volatile",
' TYPES:            "int", "long", "short",  "char", "float", "double", "void", "bool", "string",   "signed", "unsigned",
' SPECIAL TYPES:    "class", "struct", "template", "enum",
' STRUCTURE:        "switch", "case", "default",  "for", "do", "while", "continue", "break",   "if", "else", "return",   "goto",
' SPECIAL:          "const", "static",   "new", "delete",     "this", "main",  "typedef",  "operator", "namespace",
' SECURE:           "public", "private", "protected", "friend",   "inline", "virtual",
' EXCEPTION:        "catch", "try", "finally", "throw", "except",
' VALUES:           "true", "false", "null",

' OTHER:            "std", "iomanip", "include", "iostream", "cout", "cin", "endl", "INT_MIN", "INT_MAX", "MAX_RAND", "NULL"
    
    Dim rW1, rW2, rW3 As Variant
    Dim str As String
    
    rW1 = Array("int", "long", "short", "char", "float", "double", "void", "bool", "string", "signed", "unsigned")
    rW2 = Array("switch", "case", "default", "for", "do", "while", "continue", "break", "if", "else", "return", "goto")
    rW3 = Array("true", "false", "null")
    
    
    Selection_ChangeColorAllTheseWords rW1, wdColorBlue
    Selection_ChangeColorAllTheseWords rW2, wdColorRed
    
End Sub

'-------------------------------------------
Sub AN_CODE__Make_common_reserve_words_blue()
'
' AN_CODE__Make_common_reserve_words_blue Macro (by Andrew Noske 26/06/2004)
' Makes the most common code reserve words blue.
'
    Dim rW1 As Variant
    Dim str As String
    
    rW1 = Array("class", "struct", "for", "do", "while", "return", _
                    "switch", "case", "default", "for", "do", "while", "continue", "break", "if", "else", "return", "goto", _
                    "int", "long", "short", "char", "float", "double", "void", "bool", "string", _
                    "true", "false", "null")
    
    Selection_ChangeColorAllTheseWords rW1, wdColorBlue
    
End Sub



'============================================================
' OTHER MACROS:
'============================================================

'-------------------------------------------
Sub AN_TEXT__Make_quotes_italic()
'
' AN_TEXT__Make_quotes_italic Macro (by Andrew Noske 12/01/2006)
'
    Dim numFlat, numLeft, numRight, numTotal, numQuotes As Integer
    Dim chrF, chrL, chrR As String
    Dim beginFound As Boolean
    
    ActiveDocument.Bookmarks("\StartOfDoc").Select  ' move cursur to start of document
    
    chrF = """"             ' flat double quotes
    chrL = Chr(147)         ' left double quotes
    chrR = Chr(148)         ' right double quotes
    
    numQuotes = 0
    numFlat = StringFs_CountOccurancesInWholeDoc(chrF)      ' flat double quotes
    numLeft = StringFs_CountOccurancesInWholeDoc(chrL)      ' left double quotes
    numRight = StringFs_CountOccurancesInWholeDoc(chrR)     ' right double quotes
    numTotal = numFlat + numLeft + numRight
    
    If ((numTotal Mod 2) = 1) Then
        AlertMsg ("Warning: Number of double quote marks is odd")
    End If
    If (Not numLeft = numRight) Then
        AlertMsg ("Warning: Number of right & left facing double quotes does not match")
    End If
    
    '## ITERATE FROM CURSOR, HIGHLIGHT STRINGS SEPERATED BY TWO QUOTE MARKS, AND HIGHLIGHT
    beginFound = False
    For i = 1 To Document_NumCharacters
    
        If (beginFound = False) Then
            Selection.MoveRight Unit:=wdCharacter, Count:=1
            If (Selection.Characters.First = chrL Or Selection.Characters.First = chrF) Then
                Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                beginFound = True
            End If
        Else
            Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            If (Selection.Characters.Last = chrR Or Selection.Characters.Last = chrF) Then
                Selection.Font.Italic = True
                Selection.MoveRight Unit:=wdCharacter, Count:=2
                numQuotes = numQuotes + 1
                beginFound = False
            ElseIf (Selection.Characters.Last = Chr(13) Or Selection.Characters.Last = chrL) Then   ' if return character found: not a quote
                Selection.MoveRight Unit:=wdCharacter, Count:=0     'deselect
                beginFound = False
            End If
        End If
        
    Next i
    
    AlertMsg ("Found:  " & numQuotes & " sets of double quotes" & Chr(13) & _
              " ..and:  " & numTotal - (numQuotes * 2) & " lonesome quotes marks")
    
    
End Sub


'-------------------------------------------
Sub AN_OTHER_Make_Figure_Caption()
'
' Make_Figure_Caption Macro
' Macro recorded 21/10/2004 by Andrew Noske
'
    Selection.InsertCaption Label:="Figure", TitleAutoText:="InsertCaption1", _
        Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub







'############################################################
'# FUNCTIONS:
'############################################################


'============================================================
' STRING FUNCTIONS:
'============================================================

'-------------------------------------------
Public Function StringFs_CountOccurancesInWholeDoc(ByVal needle As String) As Integer
    Dim storyStr As String
    Dim storyLen As Integer
    
    storyStr = StringFs_GetAllTextInThisDoc()
    storyLen = StringFs_CountOccurances(storyStr, needle)
    
    'AlertMsg (storyStr)        '%%%%%
    'AlertMsg (storyLen)        '%%%%%
    
    StringFs_CountOccurancesInWholeDoc = storyLen
End Function

'-------------------------------------------
Public Function StringFs_GetAllTextInThisDoc() As String
    
    Dim storyStr As String
    
    Set myRange = Selection.Range
    myRange.WholeStory
    storyStr = myRange.Text
    
    'Dim storyLen As Integer
    'storyLen = Len(storyStr)
    'AlertMsg (storyLen)
    
    StringFs_GetAllTextInThisDoc = storyStr
    
End Function

'-------------------------------------------
' Replaces all occurences of Needle in Haystack with ReplaceWith.
Public Function StringFs_MyReplace(ByVal haystack As String, ByVal needle As String, ByVal replaceWith As String) As String
    
    Dim pos, start, needleLen, replaceLen As Integer
    
    needleLen = Len(needle)
    replaceLen = Len(replaceWith)
    pos = InStr(haystack, needle)
    
    While pos
      haystack = Left$(haystack, pos - 1) & replaceWith & Mid$(haystack, pos + needleLen)
      pos = InStr(pos + replaceLen, haystack, needle)
    Wend
    
    StringFs_MyReplace = haystack
    
End Function

'-------------------------------------------
Public Function StringFs_CountOccurances(ByVal haystack As String, ByVal needle As String) As Integer
    
    Dim pos, start, needleLen, numFound As Integer
    
    numFound = 0
    needleLen = Len(needle)
    pos = InStr(haystack, needle)
    
    While pos
        numFound = numFound + 1
         pos = InStr(pos + needleLen, haystack, needle)
    Wend
    
    StringFs_CountOccurances = numFound
    
End Function

'============================================================
' DOCUMENT FUNCTIONS:
'============================================================

'-------------------------------------------
Private Function Document_SetSelectionToStart()
    ActiveDocument.Bookmarks("\StartOfDoc").Select
    'Selection.start = 0
    'Selection.End = 0
End Function
Private Function Document_NumCharacters()
    Document_NumCharacters = ActiveDocument.Characters.Count
End Function

'-------------------------------------------


'============================================================
' SELECTION FUNCTIONS:
'============================================================

'-------------------------------------------
Private Function Selection_ChangeColorAllTheseWords(findArr As Variant, replaceFontColor As Long)
    
    Dim str As String
    For i = 0 To UBound(findArr)
        str = findArr(i)
        Selection_ChangeColorOfAllOccurancesOfWholeWord str, replaceFontColor
    Next i
    
End Function
'-------------------------------------------
Private Function Selection_ChangeColorOfAllOccurancesOfWholeWord(findStr As String, replaceFontColor As Long)
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "<" + findStr + ">"     'we want to find whole words
        .Replacement.Text = findStr     'we don't want to change the text
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False              'don't match case
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True          'use wildcards for "<word>" sytax
        .Replacement.Font.color = replaceFontColor  'change color <<
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Function

'-------------------------------------------
Private Function Selection_ChangeColorOfLineComment(findStr As String, replaceFontColor As Long) As Integer
    
    Dim numComments As Integer
    numComments = StringFs_CountOccurancesInWholeDoc(findStr)
    
    For i = 1 To numComments
        
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = findStr
            .Forward = True
            .Wrap = wdFindContinue
        End With
        Selection.Find.Execute                              'find/select next occurance of "findStr"
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend     'we want to select up until the end of the line
        Selection.Font.color = replaceFontColor             'change color <<
        Selection.Find.ClearFormatting                      '
        Selection.MoveRight Unit:=wdCharacter, Count:=1     'move one character forward
        
    Next i
    
    Selection_ChangeColorOfLineComment = numComments
    'AlertMsg (numComments & " comments replaced")
    
End Function


'-------------------------------------------
Private Function Selection_ReplaceAll(ByVal findStr As String, ByVal replaceStr As String)
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Replacement.Text = replaceStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Function

'-------------------------------------------
Private Function Selection_ReplaceNext(ByVal findStr As String, ByVal replaceStr As String)
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Replacement.Text = replaceStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    
End Function

'-------------------------------------------
Private Function Selection_FindNext(ByVal findStr As String)
    
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    
End Function

'============================================================
' OTHER FUNCTIONS:
'============================================================

'-------------------------------------------
Private Function AlertMsg(message As String)
    MsgBox message, vbOKOnly, "Alert"
End Function