Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: tmoore82/Word-Macros2
base: 0daef502dc
...
head fork: tmoore82/Word-Macros2
compare: Test
Checking mergeability… Don't worry, you can still create the pull request.
  • 5 commits
  • 44 files changed
  • 0 commit comments
  • 1 contributor
Commits on Sep 18, 2012
@tmoore82 copycat update 1b089ea
@tmoore82 pdf-txt-word update e042be7
Commits on Oct 01, 2012
@tmoore82 New Clear-All-Bkmks 6d622c3
Commits on Oct 09, 2012
@tmoore82 Big-Commit
First upload of all currently working macros.
1a4b116
Commits on Oct 16, 2012
@tmoore82 10-16-12
A few edits to SubSeq, mainly. Optimization and rerouting.
30dc990
Showing with 5,663 additions and 10 deletions.
  1. +508 −0 Arby.txt
  2. +368 −0 ArbyClean.txt
  3. +24 −0 Arrays.txt
  4. +241 −0 CSRF.txt
  5. +55 −0 CleanAlittle.txt
  6. +56 −0 CleanAlot.txt
  7. +21 −0 ClearBkmksSimple.txt
  8. +14 −0 ClearShapes.txt
  9. +36 −0 Constants.txt
  10. +87 −2 CopyCat.txt
  11. +81 −0 CopyStyles.txt
  12. +47 −0 CreateTable.txt
  13. +78 −0 DeHyphenate.txt
  14. +16 −0 DeleteXtraAE.txt
  15. +58 −0 DeleteXtraPara.txt
  16. +23 −0 DeleteXtraSpace.txt
  17. +14 −0 DeleteXtraTab.txt
  18. +38 −0 FindAndReplace.txt
  19. +41 −0 FixLineSpace.txt
  20. +67 −0 FontSample.txt
  21. +252 −0 Footie.txt
  22. +218 −0 HardSpace.txt
  23. +163 −0 Labels.txt
  24. +270 −0 Messages.txt
  25. +391 −0 MyStyles.txt
  26. +15 −0 Num2Text.txt
  27. +10 −5 PDF-txt-Word.vbs
  28. +657 −0 ReAlpha-Index.txt
  29. +813 −0 ReAlpha.txt
  30. +78 −0 RestorePass.txt
  31. +24 −0 SelectFiles.txt
  32. +30 −0 Str2CulrAlt.txt
  33. +28 −0 Str2Curl.txt
  34. +14 −0 StyleTable.txt
  35. +134 −0 SubSeq.txt
  36. +136 −0 SuperROGs.txt
  37. +44 −0 TOA_Repeat.txt
  38. +15 −0 Table2Text.txt
  39. +19 −0 TwoAfterCol.txt
  40. +103 −0 TwoAfterP.txt
  41. +160 −0 UnPass.txt
  42. +203 −0 XMLtxtWord.txt
  43. +13 −0 readme
  44. +0 −3  word-macros2.readme
View
508 Arby.txt
@@ -0,0 +1,508 @@
+Private iFirstPageO As Integer
+Private iFirstPageONT As Integer
+Private iFirstPageN As Integer
+Private iLineFirst As Integer
+Private iLastPageO As Integer
+Private iLastPageN As Integer
+Private iLineLast As Integer
+Private iPageDiff As Integer
+Private NumCheck As Range
+Private BwFw As String
+
+
+'Version 3
+'10/03/12
+'Arby was copied from PgLnRev (also my original) and optimized.
+'It is ready for beta testing.
+
+'10 parts. Combines with ArbyClean.
+
+'Arby is for copying parts of a transcript document and formatting
+'the resulting citations. (The name comes from "Arbitration", which
+'was the original doc type Arby was used for. It is built for
+'a specific format of transcript document and may need serious
+'alterations for other applications. The citation style may
+'also have to be updated depending on operator needs/client
+'preference.
+
+'It still gets caught on an infinite loop in certain documents.
+'This needs to be fixed.
+
+Public Sub ArbyNTp1()
+
+If MsgBox("Did you delete the index?", vbYesNo) = vbYes Then
+ ArbyNTp2
+Else
+ Exit Sub
+End If
+
+Exit Sub
+
+
+End Sub
+Private Sub ArbyNTp2()
+
+'On Error GoToErrMsg
+
+'assign the active document to a variable we can activate later
+Set SrcDoc = ActiveDocument
+
+'This variable isn't used until later.
+'It helps set unique bookmarks throughout the document.
+n = 0
+
+'add a new document, assign it a variable, turn off hidden characters
+Documents.Add
+MyStylesNT
+Set DesDoc = ActiveDocument
+ActiveWindow.ActivePane.View.ShowAll = False
+
+'go back to the source document
+SrcDoc.Activate
+
+'turn off screen updating
+Application.ScreenUpdating = False
+ClearShapes
+
+'place cursor at beginning of document
+Selection.HomeKey Unit:=wdStory
+
+'set the values for iFirstPageO and iLastPageO to 0
+'this is for the comparison coming up
+'makes sure that the first time through, iFirstPageONT doesn't interfere with the search
+iFirstPageO = Int((999 - 0 + 1) * Rnd + 0)
+iLastPageO = Int((999 - 0 + 1) * Rnd + 0)
+
+ArbyNTp3
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp3()
+
+'On Error GoToErrMsg
+
+'This should help retain iFirstPageO when looping
+iFirstPageONT = iFirstPageO
+
+'MsgBox (iFirstPageONT)
+
+'Get the Page number
+iFirstPageO = InputBox("What is the original starting page number (not Word doc page number) of the selection you want to copy?", "First Page No.")
+
+'MsgBox (iFirstPageO)
+
+'see if it's starting on the same page as before.
+'if so, go straight to the next part
+'this prevents searching for a new page number
+'going straight to the new line instead
+
+If iFirstPageO = iFirstPageONT Then
+ ArbyNTp2
+ElseIf iFirstPageO = iLastPageO Then
+ ArbyNTp2
+Else
+End If
+
+'Set a second page number variable in case the original page number didn't make the transfer
+'this will be necessary later to figure out how to get to the right line
+iFirstPageN = iFirstPageO
+
+'set a variable that determines the direction of the search
+'if the page number can be found, we can search forward from there
+'if it can't, we'll have to find the next biggest page #
+'and search backward
+BwFw = True
+
+'set a return point in case we don't find the page number
+'and we need to search again
+Search:
+
+ 'try to find the page number
+ With Selection.Find
+ .Text = "Page " & iFirstPageN
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Selection.Find.Execute
+
+ 'if you don't find it, search for the next page number
+ If Selection.Find.Found = False Then
+ iFirstPageN = iFirstPageN + 1
+ GoTo Search
+ Else
+ 'when you do find a result (original page number or not)
+ 'figure out the difference between the pages
+ 'if that difference is greater than 0, change the search direction to backward
+ If iFirstPageN <> iFirstPageO Then
+ iPageDiff = iFirstPageN - iFirstPageO
+
+ 'MsgBox (iPageDiff)
+
+ BwFw = False
+ Else
+ 'otherwise leave the search direction as forward
+ iPageDiff = 0
+ BwFw = True
+ End If
+ End If
+
+'go to the next step
+ArbyNTp4
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp4()
+
+'On Error GoToErrMsg
+
+'set a variable we can use to check against the page difference
+'set in the previous part
+Dim PD As Integer
+PD = 0
+
+'get the line number we need to search for
+iLineFirst = InputBox("On what line does your selection begin?", "First Line No.")
+
+'deselect the oriignal page number.
+'we don't need to copy that.
+Selection.MoveRight Unit:=wdCharacter, Count:=1
+
+'if the page difference isn't 0, we should be searching backward
+'so look for line number 25 (the highest line number)
+'pp - (how to avoid getting stopped by dates or other references?)
+If iPageDiff <> 0 Then
+ With Selection.Find
+ .Text = "25"
+ .Forward = False
+ .Wrap = wdFindStop
+ End With
+
+ 'search for line number NT5 as many times as the page difference
+ 'this should get us back to the right page.
+ 'pp - NT5 in text
+ Do Until PD = iPageDiff
+ Selection.Find.Execute
+ PD = PD + 1
+ Loop
+
+ 'deselect the found NT5
+ Selection.MoveLeft Unit:=wdWord, Extend:=wdMove
+Else
+ GoTo SearchNT
+End If
+
+'search point for looping
+SearchNT:
+
+If BwFw = True Then
+
+ 'find the line number, continuing to search in the same direction
+ With Selection.Find
+ .Text = CStr(iLineFirst)
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Selection.Find.Execute
+
+
+Else
+
+ 'set a range and select it (to prevent finding the "7" in "17")
+ 'pp - numbers in text
+ Set NumCheck = ActiveDocument.Range(Start:=Selection.Start - 1, End:=Selection.End)
+ NumCheck.Select
+
+ 'see if selection matches the line number
+ 'pp - numbers in text
+ If Selection.Text <> CStr(iLineFirst) Then
+ Selection.MoveLeft Unit:=wdWord, Extend:=wdMove
+ GoTo SearchNT
+ Else
+ End If
+
+End If
+
+'go to the next step
+ArbyNTp5
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp5()
+
+'On Error GoToErrMsg
+
+
+'refresh the screen, so the user can see what's happening
+Application.ScreenRefresh
+
+'get the last page number for the selection
+iLastPageO = InputBox("What is the original ending page number (not the Word doc page number) of the selection you want to copy?", "Last Page No.")
+
+'set a variable to compare against
+iLastPageN = iLastPageO
+
+'since we've actually selected stuff we want to copy, we want to redefine the range so we can keep it
+Set r = ActiveDocument.Range(Start:=Selection.Start, End:=Selection.End)
+Selection.MoveRight Unit:=wdCharacter, Count:=1
+
+'make sure searches move forward from here
+BwFw = True
+
+'see if we're working from the same page
+'if so, go to the next part
+If iLastPageO = iFirstPageO Then
+ ArbyNTp7
+ Exit Sub
+Else
+End If
+
+Search3:
+
+ 'search for the last page number
+ With Selection.Find
+ .Text = "Page " & iLastPageN
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Selection.Find.Execute
+
+ 'if you don't find it, search for the next page number
+ If Selection.Find.Found = False Then
+ iLastPageN = iLastPageN + 1
+ GoTo Search3
+ Else
+ 'extend the original selection to the end of the found text
+ r.End = Selection.End
+ r.Select
+ 'set the page difference if it's not 0, so we can get back to the right page
+ If iLastPageN <> iLastPageO Then
+ iPageDiff = iLastPageN - iLastPageO
+
+ 'MsgBox (iPageDiff)
+
+ 'set to search backward if it had to go to a larger page number
+ BwFw = False
+ Else
+ 'make sure it keeps searching forward if it found the page number
+ BwFw = True
+ End If
+ End If
+
+
+'go to the next step
+ArbyNTp7
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp7()
+
+'On Error GoToErrMsg
+
+'declare a variable for setting up our loop in case we had to go to a later page
+Dim PD As Integer
+PD = 0
+
+'get the number of the last line needed
+iLineLast = InputBox("What is the number of the last line you want to copy?", "Last Line No.")
+
+'deselect the current selection and place the cursor at the end
+Selection.MoveRight Unit:=wdCharacter, Count:=1
+
+'if the page difference isn't 0, search backward through PD number of NT5s
+'this will fail if 25 is in the text. not sure what to do about it
+If iPageDiff <> 0 Then
+
+ With Selection.Find
+ .Text = "25"
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Do Until PD = iPageDiff
+ Selection.Find.Execute
+ PD = PD + 1
+ Loop
+
+'otherwise just move on
+Else
+ GoTo Search4
+End If
+
+Search4:
+
+'if searching forward, continue searching forward
+If BwFw = True Then
+
+ Selection.MoveRight Unit:=wdCharacter, Extend:=wdMove
+
+ 'find the last line
+ With Selection.Find
+ .Text = Chr(13) & CStr(iLineLast)
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Selection.Find.Execute
+
+ 'reset the range to include everything up to this point
+ r.End = Selection.End
+ r.Select
+
+Else
+
+ Selection.MoveLeft Unit:=wdCharacter, Extend:=wdMove
+
+ 'find the last line
+ With Selection.Find
+ .Text = Chr(13) & CStr(iLineLast)
+ .Forward = BwFw
+ .Wrap = wdFindStop
+ End With
+
+ Selection.Find.Execute
+
+ 'reset the range to include everything up to this point
+ r.End = Selection.End
+ r.Select
+
+ 'select the rest of the line (we only have the number)
+ Selection.MoveEnd Unit:=wdParagraph
+
+End If
+
+'go to the next step
+ArbyNTp8
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp8()
+
+'On Error GoToErrMsg
+
+'copy the selection
+Selection.Copy
+
+'activate the destination document
+DesDoc.Activate
+
+'set up a bookmark
+'we return to this later to insert the references
+Selection.TypeText Text:=Chr(32) & "t"
+Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
+ With ActiveDocument.Bookmarks
+ .Add Range:=Selection.Range, Name:="temp" & n
+ .DefaultSorting = wdSortByName
+ .ShowHidden = True
+ End With
+Selection.MoveRight Unit:=wdCharacter, Extend:=wdMove
+
+'paste the text without formatting
+Selection.PasteSpecial DataType:=wdPasteText
+
+'go to the next step
+ArbyNTp9
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp9()
+
+
+'On Error GoToErrMsg
+
+'delete the bookmark we created earlier
+Selection.GoTo What:=wdGoToBookmark, Name:="temp" & n
+Selection.Delete
+
+n = n + 1
+
+'turn on hidden font, so we can avoid deleting things we want to keep
+Selection.Font.Hidden = True
+
+
+'create a header placeholder
+Selection.TypeText Text:=Chr(32) & "+++header"
+
+Selection.TypeParagraph
+
+'set style to "Transcript Cite"
+Selection.Style = "Transcript Cite"
+
+'now insert the reference to the copied selection
+'also in hidden text, to prevent it from being deleted later
+Selection.Font.Hidden = True
+Selection.TypeText Text:=iFirstPageO & Chr(58) & iLineFirst & Chr(32) & Chr(150) & Chr(32) & iLastPageO & Chr(58) & iLineLast
+
+Selection.TypeParagraph
+Selection.Style = "Body Text"
+'turn off hidden text and underline
+Selection.Font.Hidden = False
+
+'go to the end of the document and prepare space for more copy-pastes
+Selection.EndKey Unit:=wdStory
+Selection.TypeParagraph
+Selection.Font.Hidden = False
+
+'go to the next part
+ArbyNTp10
+
+Exit Sub
+
+ErrMsg:
+ UhOhNT
+
+End Sub
+Private Sub ArbyNTp10()
+
+'On Error GoToErrMsg
+
+'ask if there are more, if so, go to the next part
+If MsgBox("More?", vbYesNo) = vbNo Then
+ ArbyCleanNTp1
+Else
+ 'if not, go to the source document, deselect any previous selections
+ 'start back at part 3
+ SrcDoc.Activate
+ Selection.MoveRight Unit:=wdCharacter, Count:=1
+ ArbyNTp3
+End If
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
View
368 ArbyClean.txt
@@ -0,0 +1,368 @@
+'Version 2
+
+'tmoore82
+'10/02/12
+
+'Six Parts
+'Combines with ArbyNT
+
+'Most of this is client-specific cleanup. Hard to know,
+'in my limited experience, if anyone else could use this.
+'This one isn't exactly designed to run "out of the box."
+
+Public Sub ArbyCleanNTp1()
+
+
+On Error GoTo ErrMsg
+
+'place cursor at the beginning of the document
+Selection.HomeKey Unit:=wdStory
+
+'run the following macro (which populates an array with dates)
+FillstrDatesNT
+
+'set up a variable for looping through the array
+Dim d As Integer
+d = 31
+
+'change all the date text (1st, NTnd, 3rd, etc.) to hidden text
+'this is to avoid deleting them when we clean up numbers in a later step
+Do Until d = 0
+ d = d - 1
+
+ With Selection.Find
+ .Text = strDatesArray(d)
+ .Wrap = wdFindContinue
+ .Execute
+ If .Found Then Selection.Font.Hidden = True
+ Selection.MoveRight Unit:=wdCharacter, Count:=1
+ End With
+Loop
+
+'go to the next part
+ArbyCleanNTp2
+
+Exit Sub
+
+ErrMsg:
+ UhOhNT
+End Sub
+Private Sub ArbyCleanNTp2()
+
+On Error GoTo ErrMsg
+
+Selection.HomeKey Unit:=wdStory
+
+'refresh the sceen so the user knows what's happening
+Application.ScreenRefresh
+
+'replace all the CRs with pilcrows
+
+ FindThis = "^13"
+ ReplaceWithThis = "^p"
+
+ Call FindDefaultNT(FindThis, ReplaceWithThis)
+
+ArbyCleanNTp3
+
+Exit Sub
+
+ErrMsg:
+ UhOhNT
+End Sub
+Private Sub ArbyCleanNTp3()
+
+On Error GoTo ErrMsg
+
+Dim nArbyReplace
+nArbyReplace = 1
+'find the combination pilcrow#, and delete it
+
+WhichCasep3:
+
+Select Case nArbyReplace
+
+ Case 1
+
+ FindThis = "^13[0-9]{1,NT}"
+ ReplaceWithThis = Chr(0)
+
+ Case 2
+'find the combination number-tab, and delete it
+ FindThis = "[0-9]^t"
+ ReplaceWithThis = Chr(0)
+
+ Case 3
+'find all the tabs and delete them
+ FindThis = "^t"
+ ReplaceWithThis = Chr(0)
+
+ Case 4
+'find "Page ####" and delete it.
+ FindThis = "Page [0-9]{1,4}"
+ ReplaceWithThis = Chr(0)
+
+ Case 5
+'find numbers butting up against capital letters, and delete them
+ FindThis = "[0-9]{1,NT}([A-Z])"
+ ReplaceWithThis = "\1"
+
+ Case 6
+'find numbers butting up against lowercase letters, and delete them
+ FindThis = "[0-9]{1,NT}([a-z])"
+ ReplaceWithThis = "\1"
+
+ Case 7
+ 'find paragraph marks that aren't right before a capital A and delete them
+
+ FindThis = "^13([!A])"
+ ReplaceWithThis = " \1"
+
+ Case Else
+
+ GoTo MovingOnp3
+
+End Select
+
+Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+nArbyReplace = nArbyReplace + 1
+
+GoTo WhichCasep3
+
+MovingOnp3:
+
+Selection.HomeKey Unit:=wdStory
+
+FindQ:
+ 'find the capital letter Q, and add a paragraph mark before it
+ 'this could be a problem when sentences begin with Q (rare)
+ 'or a proper name that starts with Q appears in the selection (rare)
+ 'remember to proofread for those (MsgBox reminder at the end)
+ With Selection.Find
+ .Text = "Q"
+ .Replacement.Text = ""
+ .Forward = True
+ .Wrap = wdFindStop
+ .MatchWholeWord = False
+ .MatchWildcards = True
+ End With
+
+ Selection.Find.Execute
+
+ If Selection.Find.Found Then
+ Selection.TypeParagraph
+ Selection.TypeText Text:="Q"
+ GoTo FindQ:
+ End If
+
+ 'find anywhere lowercase letters butt up against a pilcrow
+ 'that is butting up against a capital letter.
+ 'Replace the pilcro with a space
+ FindThis = "([a-z])^13([A-Z])"
+ ReplaceWithThis = "\1 \2"
+
+Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ 'find any section breaks and replace them with pilcrows
+ FindThis = "^b"
+ ReplaceWithThis = "^13"
+
+Call FindDefaultNT(FindThis, ReplaceWithThis)
+
+'go to the next part
+ArbyCleanNTp4
+
+Exit Sub
+ErrMsg:
+ UhOhNT
+
+End Sub
+Private Sub ArbyCleanNTp4()
+
+On Error GoTo ErrMsg
+
+nArbyReplace = 1
+
+WhichCasep4:
+
+Select Case nArbyReplace
+
+ Case 1
+ 'find paragraph, A., space, replace with paragraph, A.,tab
+ FindThis = "^13A. "
+ ReplaceWithThis = "^pA." & Chr(9)
+
+ Case 2
+ 'find A., replace with paragraph, A.,tab
+ FindThis = "A."
+ ReplaceWithThis = "^pA." & Chr(9)
+
+ Case 3
+ 'find paragraph, Q., replace with paragraph, Q.,tab
+ FindThis = "^pQ."
+ ReplaceWithThis = "^pQ.^t"
+
+ Case Else
+
+ GoTo MovingOnp4
+
+End Select
+
+Call FindDefaultNT(FindThis, ReplaceWithThis)
+
+nArbyReplace = nArbyReplace + 1
+
+GoTo WhichCasep4
+
+MovingOnp4:
+
+'go to the next part
+ArbyCleanNTp5
+
+Exit Sub
+
+ErrMsg:
+ UhOhNT
+End Sub
+Private Sub ArbyCleanNTp6()
+
+On Error GoTo ErrMsg
+
+'refresh the sceen so the user knows what's happening
+Application.ScreenRefresh
+
+StyleSwap:
+'select the whole story and turn off hidden text
+ Selection.Find.ClearFormatting
+ Selection.Find.Style = ActiveDocument.Styles("Body Text")
+ With Selection.Find
+ .Text = ""
+ .Replacement.Text = ""
+ .Forward = True
+ .Wrap = wdFindContinue
+ .Format = True
+ .MatchCase = False
+ .MatchWholeWord = False
+ .MatchWildcards = False
+ .MatchSoundsLike = False
+ .MatchAllWordForms = False
+ End With
+ Selection.Find.Execute
+
+ If Selection.Find.Found = True Then
+ Selection.Style = "Q&A"
+ GoTo StyleSwap
+ Else
+ End If
+
+Selection.HomeKey Unit:=wdStory
+ActiveWindow.ActivePane.View.ShowAll = True
+Selection.WholeStory
+Selection.Font.Hidden = False
+Selection.HomeKey Unit:=wdStory
+
+ 'go back and find transcript citations
+ 'making their style "Transcript Cite"
+ Selection.Find.ClearFormatting
+ Selection.Find.Replacement.Style = "Transcript Cite"
+ With Selection.Find
+ .Text = "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}" & Chr(32) & Chr(150) & Chr(32) & "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}"
+ .Replacement.Text = ""
+ .Forward = True
+ .Wrap = wdFindContinue
+ .MatchWildcards = True
+ .Execute Replace:=wdReplaceAll
+ End With
+
+Selection.HomeKey Unit:=wdStory
+Dim tcr As Range
+
+ 'go back and find transcript citations
+ 'make sure the paragraph breaks in the right place
+ Selection.Find.Style = "Transcript Cite"
+ With Selection.Find
+ .Text = "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}" & Chr(32) & Chr(150) & Chr(32) & "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}[a-z]"
+ .Replacement.Text = ""
+ .Forward = True
+ .Wrap = wdFindStop
+ .MatchWildcards = True
+ .Execute Replace:=wdReplaceAll
+ End With
+
+ Do Until Selection.Find.Found = False
+ Selection.Find.Execute
+ Set tcr = ActiveDocument.Range(Start:=Selection.Start, End:=Selection.End)
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Selection.TypeParagraph
+ Selection.Style = "Q&A"
+ Loop
+
+Selection.HomeKey Unit:=wdStory
+
+ 'go back and find transcript citations butting up against upper case letters
+ 'make sure the paragraph breaks in the right place
+ Selection.Find.Style = "Transcript Cite"
+ With Selection.Find
+ .Text = "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}" & Chr(32) & Chr(150) & Chr(32) & "[0-9]{1,4}" & Chr(58) & "[0-9]{1,2}[A-Z]"
+ .Replacement.Text = ""
+ .Forward = True
+ .Wrap = wdFindStop
+ .MatchWildcards = True
+ .Execute Replace:=wdReplaceAll
+ End With
+
+ Do Until Selection.Find.Found = False
+ Selection.Find.Execute
+ Set tcr = ActiveDocument.Range(Start:=Selection.Start, End:=Selection.End)
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Selection.TypeParagraph
+ Selection.Style = "Q&A"
+ Loop
+
+DeleteXtraParaNT
+DeleteXtraAENT
+DeleteXtraSpaceNT
+DeleteXtraTabNT
+
+'cursor back to the beginning, type a paragraph, back to the beginning
+Selection.HomeKey Unit:=wdStory
+Selection.TypeParagraph
+Selection.HomeKey Unit:=wdStory
+
+'insert the placeholder for the title material
+Selection.Style = ActiveDocument.Styles("Title")
+Selection.TypeText Text:="[Claimant] v. [Defendant]"
+Selection.TypeParagraph
+Selection.TypeText Text:="Matter No. [##########]"
+
+Selection.TypeParagraph
+
+Selection.TypeText Text:="[Date] [Claimant] Proceedings " & Chr(150) & " Vol. [IIII]" & Chr(32)
+Selection.Font.Hidden = False
+Selection.TypeParagraph
+
+'cursor back to the beginning, turn hidden characters back on
+Selection.HomeKey Unit:=wdStory
+
+
+'turn screenupdating back on
+Application.ScreenUpdating = True
+
+'remind users to check the Q problem
+MsgBox ("Check to make sure paragraphs haven't been split at" _
+ & vbNewLine & Chr(9) & "-proper names starting with Q" _
+ & vbNewLine & Chr(9) & "-or sentences starting with Q." _
+ & vbNewLine & vbNewLine & "Use Find & Replace to repair any errors.")
+
+'display the final message that the macro is complete.
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+ UhOhNT
+
+End Sub
View
24 Arrays.txt
@@ -0,0 +1,24 @@
+'I use some of these arrays frequently, so I keep them all in the same place.
+
+Public Sub FillstrDatesNT()
+
+strDatesArray = Array("1st", "2nd", "3rd", "4th", "5th", "6th", "7th", "8th", "9th", "10th", "11th", "12th", "13th", "14th", "15th", "16th", "17th", "18th", "19th", "20th", "21st", "22nd", "23rd", "24th", "25th", "26th", "27th", "28th", "29th", "30th", "31st")
+
+End Sub
+
+
+Public Sub FillLowRomSearchArrayNT()
+
+ LowRomSearchArray = Array(" \(i\) ", " \(ii\) ", " \(iii\) ", " \(iv\) ", " \(v\) ", " \(vi\) ", " \(vii\) ", " \(viii\) ", " \(ix\) ", " \(x\) ", _
+ " \(xi\) ", " \(xii\) ", " \(xiii\) ", " \(xiv\) ", " \(xv\) ", " \(xvi\) ", " \(xvii\) ", " \(xviii\) ", " \(xix\) ", " \(xx\) ", _
+ " \(xxi\) ", " \(xxii\) ", " \(xxiii\) ", " \(xxiv\) ", " \(xxv\) ", " \(xxvi\) ")
+
+End Sub
+
+Public Sub FillURomSearchArrayNT()
+
+URomSearchArray = Array(" \(I\) ", " \(II\) ", " \(III\) ", " \(IV\) ", " \(V\) ", " \(VI\) ", " \(VII\) ", " \(VIII\) ", " \(IX\) ", " \(X\) ", _
+ " \(XI\) ", " \(XII\) ", " \(XIII\) ", " \(XIV\) ", " \(XV\) ", " \(XVI\) ", " \(XVII\) ", " \(XVIII\) ", " \(XIX\) ", " \(XX\) ", _
+ " \(XXI\) ", " \XXII\) ", " \(XXIII\) ", " \(XXIV\) ", " \(XXV\) ", " \(XXVI\) ")
+
+End Sub
View
241 CSRF.txt
@@ -0,0 +1,241 @@
+Public Sub CSRFNT()
+'Version 3
+
+'tmoore82
+'10/02/12 (undated until now)
+
+'This is probably about as sloppy as it gets.
+'DocXTools has a feature that clears styles and retains formatting.
+'As much as I think this is a bad idea and, at least in my application,
+'doesn't really save much time anyway, I decided to see if
+'I could reproduce the effects. I did, but I'm sure there's a better way.
+
+On Error GoTo ErrMsg
+
+Dim I As Integer
+Dim SrcDoc As Document
+Set SrcDoc = ActiveDocument
+Selection.HomeKey Unit:=wdStory
+Dim DesDoc As Document
+Set DesDoc = Documents.Add
+
+Dim strFontFormat As Font
+Dim strParaFormat As ParagraphFormat
+
+Documents(SrcDoc).Activate
+Word.Application.WindowState = wdWindowStateMinimize
+
+Selection.HomeKey Unit:=wdStory
+
+Application.ScreenUpdating = False
+
+Dim ThisWord As Range
+
+Dim StopPoint As Integer
+StopPoint = ActiveDocument.Paragraphs.Count
+
+Dim sDescription As String
+Dim sPercentComplete As Single
+
+
+For I = 1 To StopPoint Step 1
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
+ If Selection.Start = Selection.End Then
+ 'MsgBox ("Nothing to Copy")
+ Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
+ GoTo TryAgain
+ Else
+
+ Set strFontFormat = Selection.Font.Duplicate
+
+ Dim SrcLeftIndent
+ SrcLeftIndent = Selection.ParagraphFormat.LeftIndent
+
+ Dim SrcRightIndent
+ SrcRightIndent = Selection.ParagraphFormat.RightIndent
+
+ Dim SrcSpaceBefore
+ SrcSpaceBefore = Selection.ParagraphFormat.SpaceBefore
+
+ Dim SrcSpaceBeforeAuto
+ SrcSpaceBeforeAuto = Selection.ParagraphFormat.SpaceBeforeAuto
+
+ Dim SrcSpaceAfter
+ SrcSpaceAfter = Selection.ParagraphFormat.SpaceAfter
+
+ Dim SrcSpaceAfterAuto
+ SrcSpaceAfterAuto = Selection.ParagraphFormat.SpaceAfterAuto
+
+ Dim SrcLineSpacingRule
+ SrcLineSpacingRule = Selection.ParagraphFormat.LineSpacingRule
+
+ Dim SrcAlignment
+ SrcAlignment = Selection.ParagraphFormat.Alignment
+
+ Dim SrcWidowControl
+ SrcWidowControl = Selection.ParagraphFormat.WidowControl
+
+ Dim SrcKeepWithNext
+ SrcKeepWithNext = Selection.ParagraphFormat.KeepWithNext
+
+ Dim SrcKeepTogether
+ SrcKeepTogether = Selection.ParagraphFormat.KeepTogether
+
+ Dim SrcPageBreakBefore
+ SrcPageBreakBefore = Selection.ParagraphFormat.PageBreakBefore
+
+ Dim SrcNoLineNumber
+ SrcNoLineNumber = Selection.ParagraphFormat.NoLineNumber
+
+ Dim SrcHyphenation
+ SrcHyphenation = Selection.ParagraphFormat.Hyphenation
+
+ Dim SrcFirstLineIndent
+ SrcFirstLineIndent = Selection.ParagraphFormat.FirstLineIndent
+
+ Dim SrcCharacterUnitLeftIndent
+ SrcCharacterUnitLeftIndent = Selection.ParagraphFormat.CharacterUnitLeftIndent
+
+ Dim SrcCharacterUnitRightIndent
+ SrcCharacterUnitRightIndent = Selection.ParagraphFormat.CharacterUnitRightIndent
+
+ Dim SrcCharacterUnitFirstLineIndent
+ SrcCharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent
+
+ Dim SrcLineUnitBefore
+ SrcLineUnitBefore = Selection.ParagraphFormat.LineUnitBefore
+
+ Dim SrcLineUnitAfter
+ SrcLineUnitAfter = Selection.ParagraphFormat.LineUnitAfter
+
+ Dim SrcMirrorIndents
+ SrcMirrorIndents = Selection.ParagraphFormat.MirrorIndents
+
+ Dim SrcTextboxTightWrap
+ SrcTextboxTightWrap = Selection.ParagraphFormat.TextboxTightWrap
+
+ Dim SrcAutoAdjustRightIndent
+ SrcAutoAdjustRightIndent = Selection.ParagraphFormat.AutoAdjustRightIndent
+
+ Dim SrcDisableLineHeightGrid
+ SrcDisableLineHeightGrid = Selection.ParagraphFormat.DisableLineHeightGrid
+
+ Dim SrcFarEastLineBreakControl
+ SrcFarEastLineBreakControl = Selection.ParagraphFormat.FarEastLineBreakControl
+
+ Dim SrcWordWrap
+ SrcWordWrap = Selection.ParagraphFormat.WordWrap
+
+ Dim SrcHangingPunctuation
+ SrcHangingPunctuation = Selection.ParagraphFormat.HangingPunctuation
+
+ Dim SrcHalfWidthPunctuationOnTopOfLine
+ SrcHalfWidthPunctuationOnTopOfLine = Selection.ParagraphFormat.HalfWidthPunctuationOnTopOfLine
+
+ Dim SrcAddSpaceBetweenFarEastAndAlpha
+ SrcAddSpaceBetweenFarEastAndAlpha = Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha
+
+ Dim SrcAddSpaceBetweenFarEastAndDigit
+ SrcAddSpaceBetweenFarEastAndDigit = Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit
+
+ Dim SrcBaseLineAlignment
+ SrcBaseLineAlignment = Selection.ParagraphFormat.BaseLineAlignment
+
+ Selection.Copy
+
+ Documents(DesDoc).Activate
+
+ Selection.Paste
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
+ Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
+ Selection.Font = strFontFormat
+
+ Selection.ParagraphFormat.LeftIndent = SrcLeftIndent
+
+ Selection.ParagraphFormat.RightIndent = SrcRightIndent
+
+ Selection.ParagraphFormat.SpaceBefore = SrcSpaceBefore
+
+ Selection.ParagraphFormat.SpaceBeforeAuto = SrcSpaceBeforeAuto
+
+ Selection.ParagraphFormat.SpaceAfter = SrcSpaceAfter
+
+ Selection.ParagraphFormat.SpaceAfterAuto = SrcSpaceAfterAuto
+
+ Selection.ParagraphFormat.LineSpacingRule = SrcLineSpacingRule
+
+ Selection.ParagraphFormat.Alignment = SrcAlignment
+
+ Selection.ParagraphFormat.WidowControl = SrcWidowControl
+
+ Selection.ParagraphFormat.KeepWithNext = SrcKeepWithNext
+
+ Selection.ParagraphFormat.KeepTogether = SrcKeepTogether
+
+ Selection.ParagraphFormat.PageBreakBefore = SrcPageBreakBefore
+
+ Selection.ParagraphFormat.NoLineNumber = SrcNoLineNumber
+
+ Selection.ParagraphFormat.Hyphenation = SrcHyphenation
+
+ Selection.ParagraphFormat.FirstLineIndent = SrcFirstLineIndent
+
+ Selection.ParagraphFormat.CharacterUnitLeftIndent = SrcCharacterUnitLeftIndent
+
+ Selection.ParagraphFormat.CharacterUnitRightIndent = SrcCharacterUnitRightIndent
+
+ Selection.ParagraphFormat.CharacterUnitFirstLineIndent = SrcCharacterUnitFirstLineIndent
+
+ Selection.ParagraphFormat.LineUnitBefore = SrcLineUnitBefore
+
+ Selection.ParagraphFormat.LineUnitAfter = SrcLineUnitAfter
+
+ Selection.ParagraphFormat.MirrorIndents = SrcMirrorIndents
+
+ Selection.ParagraphFormat.TextboxTightWrap = SrcTextboxTightWrap
+
+ Selection.ParagraphFormat.AutoAdjustRightIndent = SrcAutoAdjustRightIndent
+
+ Selection.ParagraphFormat.DisableLineHeightGrid = SrcDisableLineHeightGrid
+
+ Selection.ParagraphFormat.FarEastLineBreakControl = SrcFarEastLineBreakControl
+
+ Selection.ParagraphFormat.WordWrap = SrcWordWrap
+
+ Selection.ParagraphFormat.HangingPunctuation = SrcHangingPunctuation
+
+ Selection.ParagraphFormat.HalfWidthPunctuationOnTopOfLine = SrcHalfWidthPunctuationOnTopOfLine
+
+ Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = SrcAddSpaceBetweenFarEastAndAlpha
+
+ Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = SrcAddSpaceBetweenFarEastAndDigit
+
+ Selection.ParagraphFormat.BaseLineAlignment = SrcBaseLineAlignment
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
+ Selection.TypeParagraph
+
+ Documents(SrcDoc).Activate
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
+ End If
+
+TryAgain:
+
+Next I
+
+Word.Application.WindowState = wdWindowStateMaximize
+Application.ScreenUpdating = True
+Documents(DesDoc).Activate
+
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+UhOhNT
+
+End Sub
View
55 CleanAlittle.txt
@@ -0,0 +1,55 @@
+Public Sub CleanAlittleNT()
+'
+'Version 6
+
+'tmoore82
+'10/02/12 (undated until now)
+'
+'The CleanAlittle Macro will both paste the source text
+'without formatting and do some cleanup
+'(extra spaces, tabs, paragraph markers, etc.) in one sweep.
+'This should save a few manual steps.
+
+On Error GoTo ErrMsg
+
+ Set SrcDoc = ActiveDocument
+
+ 'copy the selection
+ Selection.Copy
+
+ 'if another window is open, activate that one
+ 'if not, open a new doc
+ If Windows.Count > 1 Then
+ Application.Run MacroName:="NextWindow"
+ Set DesDoc = ActiveDocument
+ Else
+ Documents.Add
+ Set DesDoc = ActiveDocument
+ End If
+
+ 'paste text only
+ Selection.PasteSpecial DataType:=wdPasteText
+
+ 'change the selection to body text
+ Selection.WholeStory
+ Selection.Style = DesDoc.Styles("Body Text")
+
+ 'run the cleanup macros
+ DeleteXtraAENT
+ DeleteXtraSpaceNT
+ DeleteXtraTabNT
+ DeleteXtraParaNT
+ Str2CurlAltNT
+ TwoAfterPNT
+ HardSpace_NT
+
+ 'alert the user that the macro is complete
+ CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
56 CleanAlot.txt
@@ -0,0 +1,56 @@
+Public Sub CleanAlotNT()
+'Version 7
+
+'tmoore82
+'10/03/12
+
+'Cleans an entire document based on firm standards.
+'Formatting and anything that isn't text won't be preserved,
+'but you have the benefit of starting with a doc with no
+'underlying formatting errors or inconsistencies.
+
+'On Error GoTo ErrMsg
+
+ Set SrcDoc = ActiveDocument
+
+ 'Alert to tell operator that certain content won't be copied (tables, graphics, etc.)
+ LossAlertNT
+
+ 'preemptively converts all numbering to text
+ Num2TextNT
+
+ 'select all but last pilcrow and copy
+ Selection.HomeKey Unit:=wdStory
+ Selection.WholeStory
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
+ Selection.Copy
+
+ 'add a destination document
+ Set DesDoc = Documents.Add
+
+ 'paste text only
+ Selection.PasteSpecial DataType:=wdPasteText
+
+ 'change style to "Body Text"
+ Selection.WholeStory
+ Selection.Style = ActiveDocument.Styles("Body Text")
+
+ 'run cleanup macros
+ DeleteXtraAENT
+ DeleteXtraSpaceNT
+ DeleteXtraTabNT
+ DeleteXtraParaNT
+ Str2CurlAltNT
+ TwoAfterPNT
+ HardSpace_NT
+
+ 'alert the user that the macro is complete
+ CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
21 ClearBkmksSimple.txt
@@ -0,0 +1,21 @@
+Sub ClearBkmksSimple_NT()
+'Version v1
+'tmoore82
+'10/01/12
+
+'Simplest way I could find to clear all bookmarks from a document quickly.
+
+Dim n As Integer
+Dim nCurrentBookmark As Integer
+Dim nTotalBookmarks As Integer
+
+n = 1
+nTotalBookmarks = ActiveDocument.Bookmarks.Count
+nCurrentBookmark = 1
+
+Do Until nCurrentBookmark > nTotalBookmarks
+ ActiveDocument.Bookmarks(n).Delete
+ nCurrentBookmark = nCurrentBookmark + 1
+Loop
+
+End Sub
View
14 ClearShapes.txt
@@ -0,0 +1,14 @@
+Sub ClearShapesNT()
+'Version 1
+
+'tmoore82
+'8/29/12
+
+'About as simple as it gets. I really only have this because
+'(a) it can be combined with other macros and (b) as far as
+'I can tell, Word doesn't have a shortcut for this.
+
+ActiveDocument.Shapes.SelectAll
+ Selection.Delete
+
+End Sub
View
36 Constants.txt
@@ -0,0 +1,36 @@
+'10/09/12
+
+'It's so much easier to keep all my repeat variables in one place
+
+'Variables in consistant usage
+Public SrcDoc As Document 'Document working from
+Public DesDoc As Document 'Document copying to
+
+Public n As Integer 'for everything
+Public nBMNO As Integer 'for numbering(naming) bookmarks
+Public nColumn As Integer 'Column number
+Public nRow As Integer
+
+Public DesFold As String
+Public FindThis As String
+Public FreshFile As String
+Public ReplaceWithThis As String
+Public FirstForm As String 'to store a word before editing
+Public CheckWord As String 'to store a word after editing
+Public strCaseAlpha As String 'abstract variable for F&R
+Public strCaseNotAlpha As String 'abstract variable for F&R
+Public strDMM As String
+Public strFullName As String
+Public strName As String
+Public strNewName As String
+Public stropen As String
+Public strParseMe As String
+Public strPassword As String
+Public strPickedFile As String
+
+Public r As Range
+
+Public strDatesArray() As Variant
+Public date_element As Variant
+
+Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
View
89 CopyCat.txt
@@ -9,6 +9,10 @@
'It's commented out by default. Remember to uncomment
'or copy without the apostrophe.
+'10/09/12
+'I've moved most of this to a Word doc and formatted it for
+'easier use and access. This won't be updated anymore.
+
'a
'ascii
@@ -24,6 +28,8 @@
'Chr(32) = Space ( )
'chr(33) = exclamation point (!)
'Chr(34) = quotation mark (straight) (")
+ 'chr(40) = open parenthesis (
+ 'chr(41) = close parenthesis )
'chr(46) = period (.)
'chr(58) = colon (:)
'chr(63) = question mark (?)
@@ -44,6 +50,12 @@
' ActiveDocument.Sections(n).Footers(wdHeaderFooterPrimary). _
' PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman
+'b
+
+ 'show/hide bookmarks
+
+ 'ActiveWindow.View.ShowBookmarks = True/False
+
'c
'call macro
@@ -53,6 +65,35 @@
'carriage return
' Selection.TypeText Text:=Chr(9)
+
+ 'casting
+
+ 'CInt(variable) 'to cast as integer
+ 'CStr(variable) 'to cast as string
+
+ 'CBool(expression)
+
+ 'CByte(expression)
+
+ 'CCur(expression)
+
+ 'CDate(expression)
+
+ 'CDbl(expression)
+
+ 'CDec(expression)
+
+ 'CInt(expression)
+
+ 'CLng(expression)
+
+ 'CSng(expression)
+
+ 'CStr(expression)
+
+ 'CVar(expression)
+
+
'convert integer to string
@@ -135,7 +176,8 @@
'formats
- ' wdOpenFormatAllWord A Microsoft Word format that is backward compatible with earlier versions of Microsoft Word.
+ ' wdOpenFormatAllWord A Microsoft Word format that is backward compatible with earlier versions of Microsoft Word.
+
' wdOpenFormatAuto The existing format.
' wdOpenFormatDocument Microsoft Word format.
' wdOpenFormatEncodedText Encoded text format.
@@ -146,6 +188,10 @@
' wdOpenFormatWebPages HTML format.
' wdOpenFormatXML XML format.
+ 'full path and file name
+
+ 'ActiveDocument.FullName
+
'g
@@ -162,7 +208,11 @@
'h
- ' how "with" works
+ 'highlight
+ Selection.Range.HighlightColorIndex = wdYellow
+ Selection.Range.HighlightColorIndex = wdNoHighlight
+
+ 'how "with" works
' "with string.string" tells VBA that the following lines ".string=" should be appended to the same string. this eliminates the need to repeat the string
@@ -254,6 +304,13 @@
'Documents.Open FileName:=DesDoc
'p
+
+ 'paste
+
+ 'paste with original formatting
+
+ ' Selection.PasteAndFormat (wdFormatOriginalFormatting)
+
'progress bar (from existing form and code)
'UserForm ProgressBar must already exist
@@ -316,6 +373,12 @@
'
+ 'select all shapes
+
+ 'Sub SelectShapes()
+ 'ActiveDocument.Shapes.SelectAll
+ 'End Sub
+
'space
' Selection.TypeText Text:=Chr(32)
@@ -323,6 +386,28 @@
't
+ 'insert a table, turn borders on, go to the first cell
+
+ 'Dim myRange As Range
+ 'Set myRange = ActiveDocument.Range(Start:=0, End:=0)
+
+ 'Dim oTbl
+' Set oTbl = ActiveDocument.Tables.Add(Range:=myRange, NumRows:=10, NumColumns:=6)
+
+ 'With oTbl
+ ' .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
+ ' .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
+ ' .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
+ ' .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
+ ' .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
+ ' .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
+ ' '.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleSingle
+ ' '.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleSingle
+ ' End With
+
+'ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range.Select
+'Selection.Collapse
+
'toggle fields on/off
'ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
View
81 CopyStyles.txt
@@ -0,0 +1,81 @@
+Public Sub CopyStyles_NT()
+'Version 3
+
+'tmoore82
+'10/03/12
+
+'This macro will copy all paragraph styles from a source template
+'The destination document must be stored locally
+
+'Yes, Word has a native way of doing this. I developed the macro
+'because I was copying styles from the same template over and over
+'again, and this made one step out of six.
+
+On Error GoTo ErrMsg
+
+' Set the DesDoc as the Active Document.
+' We need to do this to get the path and filename
+Set DesDoc = ActiveDocument
+
+
+' get the path and filename of the destination document
+' store it as a string
+Dim strDesDoc As String
+strDesDoc = ActiveDocument.FullName
+
+MsgBox ("Select the document you want to copy styles from")
+
+SelectFiles_NT
+
+' store the source template path and filename as a string
+Dim strSrcDoc As String
+strSrcDoc = strPickedFile
+
+
+' open the source template
+Documents.Open strSrcDoc
+
+
+' designate a variable for the source template
+Set SrcDoc = ActiveDocument
+
+
+' declare an integer for counting
+Dim n As Integer
+
+
+' we count through the styles because there is no other way
+' to loop through the styles by name
+' this refers to a style by number, then retrieves the name
+For n = 1 To SrcDoc.Styles.Count
+
+ If SrcDoc.Styles(n).Type = wdStyleTypeParagraph Then
+
+ Dim styOrear As String
+ ' retrieve the name of the style
+ stySrc = SrcDoc.Styles(n).NameLocal
+
+ On Error Resume Next
+ Application.OrganizerCopy Source:=strSrcDoc, Destination:=strDesDoc, _
+ Name:=stySrc, Object:=wdOrganizerObjectStyles
+
+ End If
+
+BackIn:
+
+Next n
+
+'close the template
+SrcDoc.Close
+
+
+'send a message of completion
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
47 CreateTable.txt
@@ -0,0 +1,47 @@
+Sub CreateTable_NT()
+'Version 2
+
+'tmoore82
+'9/25/12
+
+'This macro creates a table in a new document.
+'There's no advantage over doing this manually, but
+'this can add power to other macros.
+
+'adding a new document
+Documents.Add
+
+'you'll need a range for the table
+Dim myRange As Range
+Set myRange = ActiveDocument.Range(Start:=0, End:=0)
+
+'row and column variables
+Dim nRows
+Dim nColumns
+
+'get user input for NumRows and NumColumns
+nColumns = InputBox("How many columns will the table have?")
+nRows = InputBox("How many rows do you need to start?")
+
+'create the table
+Dim oTbl
+Set oTbl = ActiveDocument.Tables.Add(Range:=myRange, NumRows:=nRows, NumColumns:=nColumns)
+
+ 'All borders except diagonal
+
+ With oTbl
+ .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
+ .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
+ .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
+ .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
+ .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
+ .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
+ '.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleSingle
+ '.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleSingle
+ End With
+
+'select the first cell in the table
+ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range.Select
+Selection.Collapse
+
+End Sub
View
78 DeHyphenate.txt
@@ -0,0 +1,78 @@
+Public Sub DeHyphenateNT()
+'Version 1
+
+'tmoore82
+'10/02/12 (undated until now)
+
+'This is for PDF-to-Word conversions.
+'If in the PDF lines were allowed to break within words,
+'cleaning up the hyphens is time conusming. However,
+'you don't necessarily want to take out every hyphen,
+'as some of them are appropriate.
+
+'Dehyphenate finds words with hyphens in them,
+'removes the hyphen, checks the result against the spelling
+'dictionary, and keeps it if it finds a match.
+
+'Right now, this can also remove hyphens from unwanted combos
+'like 0-60, or T-HE. Careful proofreading is still top priority.
+
+On Error GoTo ErrMsg
+
+Application.ScreenUpdating = False
+
+Selection.HomeKey Unit:=wdStory
+
+Selection.Find.ClearFormatting
+Selection.Find.Replacement.ClearFormatting
+With Selection.Find
+ .Text = "(<*)\-(*>)"
+ .Forward = True
+ .MatchWildcards = True
+ .Wrap = wdFindStop
+End With
+
+Do
+
+ Selection.Find.Execute
+ If Selection.Find.Found = False Then GoTo GetOut
+
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Selection.MoveLeft Unit:=wdWord, Count:=3, Extend:=wdExtend
+ 'MsgBox ("I found one")
+ FirstForm = Selection.Text
+ 'MsgBox (FirstForm)
+ With Selection.Find
+ .Text = "(<*)\-(*>)"
+ .Replacement.Text = "\1\2"
+ .MatchWildcards = True
+ End With
+ Selection.Find.Execute Replace:=wdReplaceOne
+ 'MsgBox (Selection.Text)
+ CheckWord = Selection.Text
+ 'MsgBox (CheckWord)
+
+ If CheckSpelling(CheckWord) = True Then
+ 'MsgBox ("It's in the dictionary.")
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ Else
+ 'MsgBox ("It's not in the dictionary.")
+ Selection.TypeText Text:=FirstForm
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+ End If
+
+Loop
+
+GetOut:
+
+ Application.ScreenUpdating = True
+
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
16 DeleteXtraAE.txt
@@ -0,0 +1,16 @@
+Public Sub DeleteXtraAENT()
+Application.ScreenUpdating = False
+
+'Time after time, in PDF-to-Word conversions, the AE
+'ligature shows up in place of an appostrophe.
+'This finds and replaces all of them.
+'I've yet to come across a doc where I actually need
+'to preserve the AE.
+
+FindThis = "�"
+ReplaceWithThis = "'"
+
+Call FindDefaultNT(FindThis, ReplaceWithThis)
+
+Application.ScreenUpdating = True
+End Sub
View
58 DeleteXtraPara.txt
@@ -0,0 +1,58 @@
+Public Sub DeleteXtraParaNT()
+
+'PDF-to-Word conversions have funny ways of breaking
+'paragraphs. This repairs some of the more common issues
+'I'm used to seeing.
+
+Application.ScreenUpdating = False
+
+n = 1
+
+WhichCase:
+
+Select Case n
+
+ Case 1
+
+ FindThis = "^13{2,}"
+ ReplaceWithThis = "^p"
+
+ Case 2
+
+ FindThis = "^13 ^13"
+ ReplaceWithThis = "^p"
+
+ Case 3
+
+ FindThis = "([a-z])^13([a-z])"
+ ReplaceWithThis = "\1 \2"
+
+ Case 4
+
+ FindThis = "([a-z]) ^13([a-z])"
+ ReplaceWithThis = "\1 \2"
+
+ Case Else
+
+ GoTo GetOut
+
+End Select
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+
+ n = n + 1
+
+GoTo WhichCase
+
+GetOut:
+
+Application.ScreenUpdating = False
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
View
23 DeleteXtraSpace.txt
@@ -0,0 +1,23 @@
+Public Sub DeleteXtraSpaceNT()
+'
+' DeleteXtraSpace Macro
+'
+'This macro, true to its name, deletes extra spaces.
+'PDF-to-Word conversions often show up with any number
+'of spaces between words, depending on the white space
+'in the original. Or, if you have a doc that uses
+'two spaces after a period, and you only want one,
+'this cleans up the extras.
+'
+'If you need a document to have two spaces after a period,
+'run this in combination with TwoAfterP.
+
+Application.ScreenUpdating = False
+
+FindThis = " {2,}"
+ReplaceWithThis = " "
+
+Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+Application.ScreenUpdating = True
+End Sub
View
14 DeleteXtraTab.txt
@@ -0,0 +1,14 @@
+Public Sub DeleteXtraTabNT()
+
+'Just like DeleteXtraSpace but for tabs
+
+Application.ScreenUpdating = False
+
+FindThis = "^9{2,}"
+ReplaceWithThis = "^t"
+
+Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+Application.ScreenUpdating = True
+
+End Sub
View
38 FindAndReplace.txt
@@ -0,0 +1,38 @@
+'10/09/12
+
+'I use find and replace a lot. It saves me a lot of space
+'and time to keep a default F&R at the ready--one that uses
+'wildcards, one that doesn't.
+
+Public Function FindWithWildCardsNT(FindThis As String, ReplaceWithThis As String)
+
+ Selection.Find.ClearFormatting
+ Selection.Find.Replacement.ClearFormatting
+
+ With Selection.Find
+ .Text = FindThis
+ .Replacement.Text = ReplaceWithThis
+ .Forward = True
+ .Wrap = wdFindContinue
+ .MatchWildcards = True
+ End With
+
+ Selection.Find.Execute Replace:=wdReplaceAll
+
+End Function
+Public Function FindDefaultNT(FindThis As String, ReplaceWithThis As String)
+
+ Selection.Find.ClearFormatting
+ Selection.Find.Replacement.ClearFormatting
+
+ With Selection.Find
+ .Text = FindThis
+ .Replacement.Text = ReplaceWithThis
+ .Forward = True
+ .Wrap = wdFindContinue
+ .MatchWildcards = False
+ End With
+
+ Selection.Find.Execute Replace:=wdReplaceAll
+
+End Function
View
41 FixLineSpace.txt
@@ -0,0 +1,41 @@
+Public Sub FixLineSpaceNT()
+'Version 3
+'9/14/12
+'tmoore82
+
+'If you work with pleading lines, you'll know what this is for.
+'Different things throw off line spacing in a doc. This lines
+'up your text with the pleading lines in a given paragraph.
+
+'Error! 10/09/12
+'Line correction inaccurate. Run more tests.
+
+Dim LineMatch As String
+
+'MsgBox InchesToPoints(Selection.Information(wdVerticalPositionRelativeToPage)) / 72 - 72
+
+LineMatch = InputBox("What line number do you need to match (left margin)?", "Line Match")
+If LineMatch = "" Then Exit Sub
+LineMatch = (LineMatch - 1) * 24
+
+Dim WrLinePos As Double
+WrLinePos = InchesToPoints(Selection.Information(wdVerticalPositionRelativeToPage)) / 72 - 72
+
+'MsgBox (WrLinePos & " " & LineMatch)
+
+Dim CorLinePos As Double
+CorLinePos = LineMatch - WrLinePos
+
+With Selection.ParagraphFormat
+ .SpaceBefore = CorLinePos
+End With
+
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
67 FontSample.txt
@@ -0,0 +1,67 @@
+Public Sub FontSample_NT()
+'Version 2
+'BetaRelease v1.0
+'tmoore82
+'10/02/12
+
+
+'Original copied from http://support.microsoft.com/kb/NT09NT05
+'10/02/12
+
+'More of a designer's tool than a doc processing need. I was trying
+'to select a font for a project, and I wanted to see what the title
+'would look like in every possible font. Then I thought of a couple
+'alternative titles. This allowed a quick scan of how it would look
+'in all the fonts available on my system.
+
+On Error GoTo ErrMsg
+
+Dim n As Integer
+Dim FontTable As Table
+
+'Start off with a new document
+Set DesDoc = Documents.Add
+
+'get the sample text from the operator
+Dim strSampleText As String
+strSampleText = InputBox("What is the text you would like to see?")
+
+'get the font size the user would like to see
+Dim nFontSize As Integer
+nFontSize = InputBox("What font size would you like?" & vbNewLine & vbNewLine & "(Must be a whole number)")
+
+'Add a table and set the table header
+Set FontTable = DesDoc.Tables.Add(Selection.Range, FontNames.Count + 1, 2)
+With FontTable
+ .Borders.Enable = False
+ .Cell(1, 1).Range.Font.Name = "Arial"
+ .Cell(1, 1).Range.Font.Bold = 1
+ .Cell(1, 1).Range.InsertAfter "Font Name"
+ .Cell(1, 2).Range.Font.Name = "Arial"
+ .Cell(1, 2).Range.Font.Bold = 1
+ .Cell(1, 2).Range.InsertAfter "Font Example"
+End With
+
+'Go through all the fonts and add them to the table
+For n = 1 To FontNames.Count
+ With FontTable
+ .Cell(n + 1, 1).Range.Font.Name = "Arial"
+ .Cell(n + 1, 1).Range.Font.Size = nFontSize
+ .Cell(n + 1, 1).Range.InsertAfter FontNames(J)
+ .Cell(n + 1, 2).Range.Font.Name = FontNames(J)
+ .Cell(n + 1, 2).Range.Font.Size = nFontSize
+ .Cell(n + 1, 2).Range.InsertAfter strSampleText
+ End With
+Next n
+
+FontTable.Sort SortOrder:=wdSortOrderAscending
+
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
252 Footie.txt
@@ -0,0 +1,252 @@
+Public Sub FootieNT()
+'Version 5
+'Beta Release v1.0
+'tmoore82
+'10/02/12 (undated until now)
+
+'Simplifies adding page numbers when a document has numerous sections.
+
+'This was one of my first big learning projects, so there's probably
+'a lot of spaghetti here. But it works great!
+
+On Error GoTo ErrMsg:
+
+'go to the main document (in case in the footer)
+ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
+
+'save current view type (so we can return the user to it later
+Dim pView
+pView = ActiveWindow.View.Type
+
+'check to see if the current window is in Print View. If not, change it. If so, save the zoom settings.
+If ActiveWindow.View.Type <> wdPrintView Then
+ ActiveWindow.View.Type = wdPrintView
+Else
+ Dim uView
+ uView = ActiveDocument.ActiveWindow.View.Zoom.Percentage
+End If
+
+'zoom to full page
+ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
+
+'delete all current headerfooters
+ ClearHeadFoot_NT
+
+'place the cursor at the beginning of the document
+Selection.HomeKey Unit:=wdStory
+
+'If MsgBox("Page Number on First Page?", vbYesNo) = vbYes Then
+'
+'Else
+'End If
+
+If MsgBox("Do you have a TOC/TOA?", vbYesNo) = vbYes Then
+
+'turn off link to previous
+NoSameAsPrevious_NT
+
+
+ Dim tocsec As Integer
+ tocsec = InputBox("What Section is your TOC in?", "TOC Section")
+
+ 'go to section containing toc
+ Selection.GoTo What:=wdGoToSection, Which:=wdGoToAbsolute, Count:=tocsec
+
+
+ 'Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
+ Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
+
+ 'go into the footer
+ ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
+
+ 'center text
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
+
+ 'insert a field
+ 'Selection.Fields.Add is the command to add the field
+ 'Range tells VBA where to put the field, in this case at the current cursor location
+ 'Type and wdFieldEmpty tells VBA not to use a specific field type
+ 'preserve formatting tells VBA whether or not to preserve the field formatting when updates are made. it defaults to false, and i'm not sure why
+ Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
+ PreserveFormatting:=False
+
+ 'text to insert in the field, which Word will then know how to interpret
+ Selection.TypeText Text:="PAGE \*MERGEFORMAT"
+
+ 'Call the Number Formatting dialog box
+ Dialogs(wdDialogFormatPageNumber).Show
+
+ 'update the field (prevents need to select all and press F9 later)
+ Selection.Fields.Update
+
+ 'go to the end of the line or selection
+ Selection.EndKey Unit:=wdLine
+
+ 'insert paragraph
+ Selection.TypeParagraph
+
+ 'align text left
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
+
+ 'return to the main document
+ ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
+
+ Dim bodsec As Integer
+ bodsec = InputBox("What section contains the main body of your document?", "Main Body Section")
+
+ 'go to section 3
+ Selection.GoTo What:=wdGoToSection, Which:=wdGoToAbsolute, Count:=bodsec
+
+ 'go into the footer
+ ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
+
+ 'center text
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
+
+ 'insert a field
+ Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
+ PreserveFormatting:=False
+
+ 'text to insert in the field, which Word will then know how to interpret
+ Selection.TypeText Text:="PAGE \*MERGEFORMAT "
+
+ 'Call the Number Formatting dialog box
+ Dialogs(wdDialogFormatPageNumber).Show
+
+ 'update the field (prevents need to select all and press F9 later)
+ Selection.Fields.Update
+
+ 'go to the end of the line or selection
+ Selection.EndKey Unit:=wdLine
+
+ Selection.TypeParagraph
+
+ 'align text left
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
+
+Else
+
+
+ 'go into the footer and set style defaults
+ ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
+
+ 'center text
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
+
+ 'insert a field
+ Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
+ PreserveFormatting:=False
+
+ 'text to insert in the field, which Word will then know how to interpret
+ Selection.TypeText Text:="PAGE \*MERGEFORMAT "
+
+ 'Call the Number Formatting dialog box
+ Dialogs(wdDialogFormatPageNumber).Show
+
+ Selection.EndKey Unit:=wdLine, Extend:=wdExtend
+
+ With Selection.HeaderFooter.PageNumbers
+ .NumberStyle = wdPageNumberStyleArabic
+ .HeadingLevelForChapter = 0
+ .IncludeChapterNumber = False
+ .ChapterPageSeparator = wdSeparatorHyphen
+ .RestartNumberingAtSection = False
+ .StartingNumber = 0
+ End With
+
+ 'update the field (prevents need to select all and press F9 later)
+ Selection.Fields.Update
+
+ 'go to the end of the line or selection
+ Selection.EndKey Unit:=wdLine
+
+ 'insert paragraph
+ Selection.TypeParagraph
+
+ 'align text left
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
+
+ 'return to the main document
+ ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
+
+
+End If
+
+If MsgBox("Do you have additional sections that require page numbers?", vbYesNo) = vbYes Then
+
+ 'declare a new variable that gives us a starting point to run a loop
+ Dim rerun As Integer
+ If bodsec <> 0 Then
+ rerun = bodsec
+ Else
+ rerun = 1
+ End If
+ Selection.GoTo What:=wdGoToSection, Which:=wdGoToAbsolute, Count:=rerun
+
+ Do Until rerun = ActiveDocument.Sections.Count
+
+ Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Count:=1
+
+ If MsgBox("Insert page numbers in this section?", vbYesNo) = vbYes Then
+ 'go into the footer
+ ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
+
+ 'center text
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
+
+ 'insert a field
+ Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
+ PreserveFormatting:=False
+
+ 'text to insert in the field, which Word will then know how to interpret
+ Selection.TypeText Text:="PAGE \*MERGEFORMAT "
+
+ 'Call the Number Formatting dialog box
+ Dialogs(wdDialogFormatPageNumber).Show
+
+ 'update the field (prevents need to select all and press F9 later)
+ Selection.Fields.Update
+
+ 'go to the end of the line or selection
+ Selection.EndKey Unit:=wdLine
+
+ Selection.TypeParagraph
+
+ 'align text left
+ Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
+
+ 'return to the main document
+ ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
+
+ rerun = rerun + 1
+
+ Else
+
+ rerun = rerun + 1
+
+ End If
+
+ Loop
+Else
+End If
+
+
+
+InsertDocNoInFooters
+
+
+'return to the main document
+ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
+
+'place the cursor at the beginning of the document
+Selection.HomeKey Unit:=wdStory
+
+CompletedNT
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
218 HardSpace.txt
@@ -0,0 +1,218 @@
+Public Sub HardSpace_NT()
+'Version 2
+
+'tmoore82
+'09/28/12
+
+'There are a lot of places a document needs a
+'non-breaking space, such as after (a)[hard space]this item,
+'(b)[hard space]that item, etc. This macro
+'tries to catch the most common ones.
+
+'This isn't completely functional yet. It catches a lot, but
+'not everything.
+
+'On Error GoTo ErrMsg
+
+Application.ScreenUpdating = False
+
+n = 1
+
+WhichCase:
+
+Select Case n
+
+ Case 1
+
+ FindThis = " \(([a-z])\) ([a-z])"
+ ReplaceWithThis = " " & Chr(40) & "\1" & Chr(41) & Chr(160) & "\2"
+
+ Case 2
+
+ FindThis = " \(([a-z])\) ([A-Z])"
+ ReplaceWithThis = " " & Chr(40) & "\1" & Chr(41) & Chr(160) & "\2"
+
+ Case 3
+
+ FindThis = " \(([0-9])\) ([a-z])"
+ ReplaceWithThis = " " & Chr(40) & "\1" & Chr(41) & Chr(160) & "\2"
+
+ Case 4
+
+ FindThis = " \(([0-9])\) ([A-Z])"
+ ReplaceWithThis = " " & Chr(40) & "\1" & Chr(41) & Chr(160) & "\2"
+
+ Case 5
+
+ FindThis = Chr(160) & "\(([0-9])\) days"
+ ReplaceWithThis = " \1" & Chr(160) & "days"
+
+ Case 6
+
+ FindThis = Chr(160) & "\(([0-9])\) weeks"
+ ReplaceWithThis = " \1" & Chr(160) & "weeks"
+
+ Case 7
+
+ FindThis = Chr(160) & "\(([0-9])\) months"
+ ReplaceWithThis = " \1" & Chr(160) & "months"
+
+ Case 8
+
+ FindThis = Chr(160) & "\(([0-9])\) years"
+ ReplaceWithThis = " \1" & Chr(160) & "years"
+
+
+ Case 9
+
+ FindThis = Chr(160) & "\(([0-9])\) day"
+ ReplaceWithThis = " \1" & Chr(160) & "day"
+
+ Case 10
+
+ FindThis = Chr(160) & "\(([0-9])\) week"
+ ReplaceWithThis = " \1" & Chr(160) & "week"
+
+ Case 11
+
+ FindThis = Chr(160) & "\(([0-9])\) month"
+ ReplaceWithThis = " \1" & Chr(160) & "month"
+
+ Case 12
+
+ FindThis = Chr(160) & "\(([0-9])\) year"
+ ReplaceWithThis = " \1" & Chr(160) & "year"
+
+ Case 13
+
+ HardSpaceLromNT
+
+ Case Else
+
+ GoTo GetOut
+
+End Select
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+
+ n = n + 1
+
+GoTo WhichCase
+
+GetOut:
+
+Application.ScreenUpdating = False
+
+Exit Sub
+
+ErrMsg:
+
+ UhOhNT
+
+End Sub
+Private Sub HardSpaceLromNT()
+'Version 1
+
+'tmoore82
+'9/28/12
+
+
+'On Error GoTo ErrMsg
+
+Application.ScreenUpdating = False
+
+LowRomSearchArray = Array(" \(i\) ", " \(ii\) ", " \(iii\) ", " \(iv\) ", " \(v\) ", " \(vi\) ", " \(vii\) ", " \(viii\) ", " \(ix\) ", " \(x\) ", _
+ " \(xi\) ", " \(xii\) ", " \(xiii\) ", " \(xiv\) ", " \(xv\) ", " \(xvi\) ", " \(xvii\) ", " \(xviii\) ", " \(xix\) ", " \(xx\) ", _
+ " \(xxi\) ", " \(xxii\) ", " \(xxiii\) ", " \(xxiv\) ", " \(xxv\) ", " \(xxvi\) ")
+
+Dim nLowRom As Integer
+
+Dim n As Integer
+n = 1
+
+Select Case n
+
+ Case 1
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = " (" & LowRomSearchArray(nLowRom) & ")" & " ([A-Z])"
+ ReplaceWithThis = "\1" & Chr(160) & "\2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case 2
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = "Section (" & LowRomSearchArray(nLowRom) & ")" & Chr(160) & "([A-Z])"
+ ReplaceWithThis = "Section \1 \2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case 3
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = " (" & LowRomSearchArray(nLowRom) & ")" & " ([a-z])"
+ ReplaceWithThis = "\1" & Chr(160) & "\2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case 4
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = "Section (" & LowRomSearchArray(nLowRom) & ")" & Chr(160) & "([a-z])"
+ ReplaceWithThis = "Section \1 \2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case 5
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = "Clause (" & LowRomSearchArray(nLowRom) & ")" & Chr(160) & "([A-Z])"
+ ReplaceWithThis = "Section \1 \2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case 6
+
+ For nLowRom = LBound(LowRomSearchArray) To UBound(LowRomSearchArray)
+
+ FindThis = "Clause (" & LowRomSearchArray(nLowRom) & ")" & Chr(160) & "([a-z])"
+ ReplaceWithThis = "Section \1 \2"
+
+ Call FindWithWildCardsNT(FindThis, ReplaceWithThis)
+
+ Next nLowRom
+
+ Case Else
+
+ GoTo GetOut
+
+End Select
+
+GetOut:
+
+Application.ScreenUpdating = True
+
+Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
163 Labels.txt
@@ -0,0 +1,163 @@
+Sub LabelsNT()
+'Version 3
+
+'tmoore82
+'10/01/2012
+
+'v1.2
+'updated to skip rows used as spacers
+
+'This has more or less the same function as a mail merge,
+'but it doesn't require you to have fields to pull from.
+'Labels copies each paragraph in your source document
+'to a label (table cell) in the destination document.
+
+'It was developed for labels, but, clearly, it can also be really
+'useful for populating tables.
+
+'This includes a progress bar, but without the form and code,
+'you'll need to leave those commented out.
+
+ 'On Error GoToErrMsg:
+
+ Dim iNumCol As Integer
+ iNumCol = InputBox("How many columns are in the label template?")
+' MsgBox (iNumCol)
+ Application.ScreenUpdating = False
+
+ Set SrcDoc = ActiveDocument
+ Application.Run MacroName:="NextWindow"
+
+ Set DesDoc = ActiveDocument
+
+ Dim iCurCol As Integer
+ iCurCol = 1
+ Dim nCurRow As Integer
+ nCurRow = 1
+
+ Dim nWidth
+ nWidth = Selection.Tables(1).Columns(1).PreferredWidth
+
+ Dim nHeight
+ nHeight = Selection.Tables(1).Rows(1).Height
+
+ SrcDoc.Activate
+
+ Selection.HomeKey Unit:=wdStory
+ Word.Application.WindowState = wdWindowStateMinimize
+ Dim iLabelCount As Integer
+ iLabelCount = ActiveDocument.Paragraphs.Count
+
+ Dim iCounter As Integer
+ iCounter = 1
+
+ Dim pb As Integer
+ pb = 1
+
+ If iNumCol = 1 Then
+
+ 'ProgressBar.Show
+ 'Dim sDescription As String
+ 'Dim sPercentComplete As Single
+
+ Do Until iCounter > iLabelCount
+
+
+ ' sDescription = "Macro Progress"
+ 'sPercentComplete = (pb / iLabelCount) * 100
+ 'ProgressBar.Increment sPercentComplete, sDescription
+
+ 'pb = pb + 1
+
+ Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
+
+ Selection.Copy
+
+ DesDoc.Activate
+
+ Selection.PasteAndFormat (wdFormatOriginalFormatting)
+ Selection.MoveRight Unit:=wdCell
+ nCurRow = nCurRow + 1
+
+ If Selection.Tables(1).Rows(nCurRow).Height <> nHeight Then
+ Selection.MoveDown Unit:=wdLine, Count:=1
+ nCurRow = nCurRow + 1
+ End If
+
+ SrcDoc.Activate
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1
+
+ iCounter = iCounter + 1
+ Loop
+
+ Else
+
+ Do Until iCounter > iLabelCount
+
+ 'ProgressBar.Show
+ 'sDescription = "Macro Progress"
+ 'sPercentComplete = (pb / iLabelCount) * 100
+ 'ProgressBar.Increment sPercentComplete, sDescription
+
+ 'pb = pb + 1
+
+ Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
+ Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
+
+ Selection.Copy
+
+ DesDoc.Activate
+
+ Selection.PasteAndFormat (wdFormatOriginalFormatting)
+ Selection.MoveRight Unit:=wdCell
+
+' MsgBox (Selection.Tables(1).Rows(nCurRow).Height)
+
+ If Selection.Tables(1).Rows(nCurRow).Height <> nHeight Then
+ Selection.MoveDown Unit:=wdLine, Count:=1
+ nCurRow = nCurRow + 1
+ End If
+
+ iCurCol = iCurCol + 1
+ ' MsgBox (iCurCol)
+ If iCurCol = iNumCol Then
+ iCurCol = 0
+ ' MsgBox (iCurCol)
+ ElseIf Selection.Tables(1).Columns(iCurCol).PreferredWidth <> nWidth Then
+ Selection.MoveRight Unit:=wdCell
+ iCurCol = iCurCol + 1
+ ' MsgBox (iCurCol)
+ If iCurCol = iNumCol Then
+ iCurCol = 0
+ nCurRow = nCurRow + 1
+ ' MsgBox (iCurCol)
+ Else
+ End If
+ End If
+
+ SrcDoc.Activate
+
+ Selection.MoveDown Unit:=wdParagraph, Count:=1
+
+ iCounter = iCounter + 1
+ Loop
+
+ End If
+
+' Unload ProgressBar
+
+ CompletedNT
+
+ Application.ScreenUpdating = True
+ Word.Application.WindowState = wdWindowStateMaximize
+ DesDoc.Activate
+
+ Exit Sub
+
+ErrMsg:
+
+UhOhNT
+
+End Sub
View
270 Messages.txt
@@ -0,0 +1,270 @@
+'These are alerts I use to keep the operator informed.
+'Most of my macros reference them. If you are trying to
+'use any of my macros "out of the box," you'll need
+'a module with these in there.
+
+Public strQarray(100) As String
+Public strQ As String