' Word macros useful with ABBYY FineReader and other situations that need to
'  remove many styles and make major formatting changes.  Version of 3/5/2014
'  From http://archivehistory.jeksite.com/download/download.htm.


Sub Switch_Chars()
'
' Switches the two characters to the left of the cursor. set to hotkey.
'
'
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Cut
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub
Sub Upper_Case()
'
' Makes character upper case and advances to next character. set to hotkey like Ctrl-UpArrow.
'
'
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Range.Case = wdUpperCase
    Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub
Sub Lower_Case()
'
' Makes character lower case and advances to next character. set to hotkey like Ctrl-DnArrow.
'
'
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Range.Case = wdLowerCase
    Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub
Sub TOC_for_HTML()
'
' TOC_for_HTML Macro
'
'
    ' go to end of file and add new page at end for TOC
    Selection.EndKey Unit:=wdStory
    Selection.InsertBreak Type:=wdPageBreak
    
    ' make TOC with style heading 2 only and set as TOC level 1
    With ActiveDocument
       .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
          True, UseHeadingStyles:=True, LowerHeadingLevel:=2, _
          UpperHeadingLevel:=1, IncludePageNumbers:=False, _
          UseHyperlinks:=True, _
          HidePageNumbersInWeb:=True, UseOutlineLevels:=False
        .TablesOfContents(1).TabLeader = wdTabLeaderDots
        .TablesOfContents.Format = wdIndexIndent
    End With
    
    ' put active filename and path in variable
    strDocName = ActiveDocument.FullName

    'Strip off extension and add ".htm" extension
      intPos = InStrRev(strDocName, ".")
      strDocName = Left(strDocName, intPos - 1)
      strDocName = strDocName & ".htm"

    ' output to filtered html with new file name in same folder
    ActiveDocument.SaveAs FileName:=strDocName, FileFormat:= _
        wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    
End Sub
Sub No_indent()
'
' No_indent Macro
' Makes no indent for first line of paragraph
'
    With Selection.ParagraphFormat
        .FirstLineIndent = InchesToPoints(0)
    End With
End Sub
Sub SelectParagraph()
'
' SelectParagraph Macro
'
'
 Selection.Paragraphs(1).Range.Select
 
End Sub
Sub paragr_to_manual_return()
'
' paragr_to_manual_return Macro
'   finds next paragraph marker and replaces it with a manual return
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^l"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceOne
    Selection.MoveRight Unit:=wdCharacter, Count:=1

End Sub
Sub EndOfParagraph()
'

'  Go to end of paragraph. start by moving right 1 char in case at end of paragraph.
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
End Sub
Sub SelectToEndOfSentence()
'
' Select to end of sentence inside the period.
' Start by selecting one char to right to move over a period if one is there
  Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
  With Selection
    .Extend Character:="."
  End With
  Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

End Sub
Sub Para2ptAfter()
'
' Set 2 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 2
End Sub
Sub Para0ptAfter()
'
' Set 0 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 0
End Sub

Sub Para3ptAfter()
'
' Set 3 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 3
End Sub
Sub Para4ptAfter()
'
' Set 4 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 4
End Sub
Sub Para6ptAfter()
'
' Set 6 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 6
End Sub
Sub Para9ptAfter()
'
' Set 9 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 9
End Sub
Sub Para12ptAfter()
'
' Set 12 pt spacing after paragraph
'
'
    Selection.Paragraphs.SpaceAfter = 12
End Sub

Sub ParaPlus6ptAfter()
'
' Add 6 pt to spacing after the paragraph
'
    Selection.Paragraphs.SpaceAfter = (Selection.Paragraphs.SpaceAfter) + 6
End Sub
Sub Remove_User_Styles()
'
' Word Macro that removes all styles created by a user (not built in).
'  ABBY FineReader makes many junky styles that need to be removed and can cause errors
'  when deleting them (such as duplicate styles). Usually making another pass will delete
'  more styles and all of them will be deleted with enough passes.  This macro skips a style
'  if there is an error and keeps looping to remove styles as long as it removes some with
'  each pass. If a pass fails to remove any styles or 20 passes have been tried, the macro
'  stops and lets the user know how many styles need to be deleted manually. It also stops
'  if more than 50 errors occur in one pass. It always lets the user know how many styles
'  were deleted.
 
 Dim nerr, lagnerr, nstyles, ndel, iadd, iouter As Integer
 
 Do
   iouter = iouter + 1                    ' counter to quit if too many loops
   lagnerr = nerr                         ' keep number of errors on previous pass
   nerr = 0                               ' number of errors on this pass
   nstyles = ActiveDocument.Styles.Count
   For iloop = nstyles To 1 Step -1        ' working backwards is more reliable for deleting
     If ActiveDocument.Styles(iloop).BuiltIn = False Then
       iadd = 1                            ' used to tell if a style is deleted
       On Error GoTo ErrorHandler    ' handle error during delete
       ActiveDocument.Styles(iloop).Delete
       On Error GoTo 0               ' turn on normal error handling
       ndel = ndel + iadd            ' increment n deleted unless was error
     End If
   Next iloop
 Loop Until nerr = 0 Or nerr = lagnerr Or iouter = 21
 
 If nerr > 0 Then
   MsgBox ("ERRORS. " + Str(nerr) + " user styles need to be removed manually. " + vbCr _
            + Str(ndel) + " styles removed by the macro.")
 Else
   MsgBox ("All user styles have been removed." + vbCr _
            + Str(ndel) + " styles removed by the macro.")
 End If
 Exit Sub        ' normal exit

ErrorHandler:
    nerr = nerr + 1
    iadd = 0
    If nerr < 51 Then
   '   MsgBox Prompt:="Error " & Str(nerr) & " Deleting Style " & Str(iloop) & " of " & Str(ntmp)
      Resume Next
    Else
      MsgBox ("More than 50 errors in one pass removing styles. Exiting Remove Styles procedure." + vbCr _
            + Str(ndel) + " styles removed by the macro.")
 '    Dialogs(wdDialogOrganizer).Show
      Exit Sub
    End If
End Sub
Sub NextGraphic()
'
' Go to next picture/graphic object
'
'
    Selection.GoTo What:=wdGoToGraphic, Which:=wdGoToNext, Count:=1, Name:=""
End Sub
Sub PreviousGraphic()
'
' Go to previous picture/graphic object
'
'
    Selection.GoTo What:=wdGoToGraphic, Which:=wdGoToPrevious, Count:=1, Name:=""
End Sub
Sub MoveObjLeft()
'
' move a selected object left 4 points. auto determines if is shape or frame
'  if inlineshape, offer option to convert and move
'  Shape may be stuck until moved with a simple arrow key.
'
  If Selection.Frames.Count > 0 Then
    ntmp = Selection.Frames(1).HorizontalPosition
  ' MsgBox ("ntmp=" + Str(ntmp))
    If ntmp > -900000 Then
      Selection.Frames(1).HorizontalPosition = ntmp - 4
    End If
  ' see if selection is an inlineshape and move if so
  ElseIf Selection.InlineShapes.Count > 0 Then
    ntmp = MsgBox("Object is InlineShape and cannot be moved. Convert to normal Shape?", vbYesNo)
    If ntmp = vbNo Then
      Exit Sub
    End If
    Selection.InlineShapes(1).ConvertToShape
    ' convert to shape looses selection, so select newest shape.
    ntmp = ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(ntmp).Select
    Selection.ShapeRange(1).IncrementLeft (-4)
 ' see if selection is a shape and move if so
  ElseIf Selection.ShapeRange.Count > 0 Then
    Selection.ShapeRange(1).IncrementLeft (-4)
  End If

End Sub
Sub MoveObjRight()
'
' move a selected object Right 4 points. auto determines if is shape or frame
'  if inlineshape, offer option to convert and move
'  Shape may be stuck until moved with a simple arrow key.
'
 
  If Selection.Frames.Count > 0 Then
    ntmp = Selection.Frames(1).HorizontalPosition
   ' MsgBox ("ntmp=" + Str(ntmp))
    If ntmp > -900000 Then
      Selection.Frames(1).HorizontalPosition = ntmp + 4
    End If
  ' see if selection is an inlineshape and move if so
  ElseIf Selection.InlineShapes.Count > 0 Then
    ntmp = MsgBox("Object is InlineShape and cannot be moved. Convert to normal Shape?", vbYesNo)
    If ntmp = vbNo Then
      Exit Sub
    End If
    Selection.InlineShapes(1).ConvertToShape
    ' convert to shape looses selection, so select newest shape.
    ntmp = ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(ntmp).Select
    Selection.ShapeRange(1).IncrementLeft (4)
 ' see if selection is a shape and move if so
  ElseIf Selection.ShapeRange.Count > 0 Then
    Selection.ShapeRange(1).IncrementLeft (4)
  End If

End Sub
Sub MoveObjUp()
'
' move a selected object up 4 points. auto determines if is shape or frame
'  if inlineshape, offer option to convert and move
'  Shape may be stuck until moved with a simple arrow key.
'
 
  If Selection.Frames.Count > 0 Then
    ntmp = Selection.Frames(1).VerticalPosition
 '  MsgBox ("ntmp=" + Str(ntmp))
    If ntmp > -900000 Then
      Selection.Frames(1).VerticalPosition = ntmp - 4
    End If
  ' see if selection is an inlineshape and move if so
  ElseIf Selection.InlineShapes.Count > 0 Then
    ntmp = MsgBox("Object is InlineShape and cannot be moved. Convert to normal Shape?", vbYesNo)
    If ntmp = vbNo Then
      Exit Sub
    End If
    Selection.InlineShapes(1).ConvertToShape
    ' convert to shape looses selection, so select newest shape.
    ntmp = ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(ntmp).Select
    Selection.ShapeRange(1).IncrementTop (-4)
 ' see if selection is a shape and move if so
  ElseIf Selection.ShapeRange.Count > 0 Then
    Selection.ShapeRange(1).IncrementTop (-4)
  End If

End Sub
Sub MoveObjDown()
'
' move a selected object down 4 points. auto determines if is shape or frame
'  if inlineshape, offer option to convert and move
'  Shape may be stuck until moved with a simple arrow key.
 
  If Selection.Frames.Count > 0 Then
    ntmp = Selection.Frames(1).VerticalPosition
   ' MsgBox ("ntmp=" + Str(ntmp))
    If ntmp > -900000 Then
      Selection.Frames(1).VerticalPosition = ntmp + 4
    End If
  ' see if selection is an inlineshape and move if so
  ElseIf Selection.InlineShapes.Count > 0 Then
    ntmp = MsgBox("Object is InlineShape and cannot be moved. Convert to normal Shape?", vbYesNo)
    If ntmp = vbNo Then
      Exit Sub
    End If
    Selection.InlineShapes(1).ConvertToShape
    ' convert to shape looses selection, so select newest shape.
    ntmp = ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(ntmp).Select
    Selection.ShapeRange(1).IncrementTop (4)
  ' see if selection is a shape and move if so
  ElseIf Selection.ShapeRange.Count > 0 Then
    Selection.ShapeRange(1).IncrementTop (4)
  End If

End Sub
Sub FineReaderFrames()
'
' FineReaderFrames Macro
'
' This macro is designed for processing a Word document output by ABBY FineReader OCR.
'  It converts frames with text to textboxes, and converts pictures in frames (inlineshapes) to
'  standard pictures (shapes). This does not convert frames with tables because the
'  location and structure of the tables was unreliable when pulled out of frames.
'  Inlineshape pictures are on the text layer of Word and cannot be easily moved or replaced.
'  Shape pictures are on the drawing layer of Word and can be easily moved and replaced.
'  Paragraph styles can be applied to textboxes but not to frames (the text jumps out of the
'  frame if a style is applied). Textboxes are also shapes on the drawing layer of Word.
'  Note: Pictures and textboxes as shapes have an anchor that must be located on the text layer of
'        the document. An anchor is in a paragraph marker in a frame or directly on the text layer.
'        If the anchor gets deleted, the associated picture or textbox is deleted. The anchors can
'        unpredictably jump around or be deleted if the frame with the anchor is moved or deleted,
'        or if the associated picture or textbox is moved. Frames have to be deleted carefully.
'        It is easiest if the frames do not overlap in the document from FineReader. When anchors
'        are in frames, this macro does not attempt to delete the frame, but removes the text and
'        makes the frame small in the left margin 3 inches from the top of the page.
'      NOTE: for reasons that I do not understand, this macro often deletes the text in tables
'            unless the table is on the last page being processed. That may need to be worked around.
'  Note: also that it is important to set the Wrap type for the new textboxes and pictures to be
'        in front of text (since there is not relevant text). Otherwise, the anchors in paragraph
'        markers can easily get pushed off the page and make objects jump around uncontrolably.
'  This macro also aligns the text and pictures relative to the margins and increases the contrast
'  of picture by 5%--which also converts the picture from grayscale to color (which is much
'  better when converting to pdf). Main limit based on PJ book is assumption of column width of 3.38.

  
  Dim iframe As frame
  Dim iinline As InlineShapes
  Dim ishape, iboxshape As Shape
  Dim nxposition, nyposition, nwidth, nheight, ntopmarg, npagewidth, nleftmarg, nrightmarg
  Dim nframes, nshapes, ninlines, ntables, iloop As Integer
  Dim atext As String
  Dim ax, ay As String * 1
  
  Call ObjectCounts    ' displays counts of pictures, frames, etc.
  
  
  ' go to header on this page, which allows reading margins (cannot read from within frame or picture)
  '   Remember, margins are different for odd and even pages. For mirrored, .left and .right are used
  '   as inside and outside and are fixed for all pages. No easy way to programatically adjust a page.
  ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
  ntopmarg = Selection.PageSetup.TopMargin                '  margins for this page
  nleftmarg = Selection.PageSetup.LeftMargin
  nrightmarg = Selection.PageSetup.RightMargin
  npagewidth = InchesToPoints(8.5) - nrightmarg - nleftmarg
  ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument    ' go back to main body of doc
  
  
  ' *** process any shapes that are not in frames *** includes junk background images FineReader
  ' sometimes makes (on drawing layer). set pictures and textboxes relative to margins.
  If ActiveDocument.Shapes.Count > 0 Then
    
    For Each ishape In ActiveDocument.Shapes
      If ishape.Type <> msoPicture And ishape.Type <> msoLinkedPicture And _
         ishape.Type <> msoTextBox Then
        MsgBox ("Deleting Unexpected Nonpicture Shape. Type=" + Str(ishape.Type))
        ishape.Delete
      Else
        ' position picture or textbox relative to margins
        With ishape
          ' get shape info
          nxposition = .Left
          nyposition = .Top
          nwidth = .Width
          nheight = .Height
          '  set frame horizontally relative to left margin (right margin apparently does not work in VBA)
          .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
          If nxposition <= InchesToPoints(1.25) Then
             .Left = 0                           ' if close to margin, set on margin
          ElseIf nxposition + nwidth >= InchesToPoints(7.25) Then
             .Left = npagewidth - nwidth         ' set to right margin based on left margin
             ' if not on a margin, leave horizontal as is but relative to margin. Shapes
             '  automatically handle margins
          End If
          ' set frame relative to vertical margin
          .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
          If nyposition <= InchesToPoints(1.25) Then
            .Top = 0
          Else
            .Top = nyposition - ntopmarg
          End If
          If ishape.Type = msoPicture Or ishape.Type = msoLinkedPicture Then
            ' increase picture contrast by 5% -- also converts from grayscale to color
            .PictureFormat.IncrementContrast 0.05
          End If
        End With  ' end with ishape
      End If  ' end if picture or textbox
    Next ishape
  End If   ' end if nshapes > 0

  ' *** process frames ***
  nframes = ActiveDocument.Frames.Count
  If nframes > 0 Then
   For iloop = nframes To 1 Step -1           ' process backwards or frame delete gives errors
     Set iframe = ActiveDocument.Frames(iloop)
         
     ' get and store frame info
     With iframe
       atext = .Range.Text                    ' text in the frame
       ninlines = .Range.InlineShapes.Count   ' for FineReader pictures start as inlineshapes in frames
       nshapes = .Range.ShapeRange.Count      ' may get some of these if doc has had some processing
       ntables = .Range.Tables.Count          ' tables in the frame
       nwidth = .Width                        ' width and height of frame. are -1 if size adaptes to content
       nheight = .Height
       ' get original positions relative to page edges. ABBY FineReaders centers on page
       .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
       .RelativeVerticalPosition = wdRelativeVerticalPositionPage
       nxposition = .HorizontalPosition        ' position of upper right corner of frame
       nyposition = .VerticalPosition
     End With
   
     iframe.Select                     ' puts cursor on page being processed
  ' MsgBox ("l,r,t,width=" + Str(nleftmarg) + ", " + Str(nrightmarg) + ", " + Str(ntopmarg) + ", " + Str(npagewidth))
     
     ' if pictures in frames, set associated variable and get size if needed
     If ninlines > 0 Then
       Set iinline = iframe.Range.InlineShapes
       
       ' if frame size is auto (width=-1), use picture size for width and height
       If nwidth < 0 Then
         nwidth = iinline(1).Width
       End If
       If nheight < 0 Then
         nheight = iinline(1).Height
       End If
     End If
    
     ' set var indicating final position. L=left margin, R=right margin, T=top margin, S=stay as is.
     '   3.375 is column width for book. Use that for text with auto width--usually picture caption
     If nxposition <= InchesToPoints(1.25) Then
       ax = "L"
     ElseIf nxposition + nwidth >= InchesToPoints(7.25) Or _
            (nwidth < 0 And nxposition + InchesToPoints(3.375) > InchesToPoints(7.25)) Then
       ax = "R"
     Else
       ax = "S"
     End If
     If nyposition <= InchesToPoints(1.25) Then
       ay = "T"
     Else
       ay = "S"
     End If
   
   ' *** frame with tables  *** leave as frame, but set frame position
     If ntables > 0 Then
       With iframe
         '  set frame relative to horizontal margin
         .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
         If ax = "L" Then
           .HorizontalPosition = wdFrameLeft     ' set to left margin
         ElseIf ax = "R" Then
           .HorizontalPosition = wdFrameRight    ' set to right margin
         Else
           ' if not on a margin, leave horizontal as is but relative to margin
           '  frames do not automatically handle margins, so get close here
           .HorizontalPosition = nxposition - nleftmarg
         End If
         ' set frame relative to vertical margin
         .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
         If ay = "T" Then
           .VerticalPosition = wdFrameTop     ' set to top margin
         Else
           ' if not on top margin, leave vertical as is but relative to margin
           .VerticalPosition = nyposition - ntopmarg
         End If
       End With
     
   ' *** frame with text *** make textboxes for text and delete frame unless it
     '   also has an anchor for a picture or another textbox. frame with only an inlineshape
     '   picture has a text length of 1.
     ElseIf Len(atext) > 1 Then
       ' delete frame before creating textbox -- otherwise textbox may get deleted with frame.
       '  do not delete frame if it has a picture or an anchor for a picture or textbox from a
       '  previous loop
       iframe.Select
       If ninlines = 0 And nshapes = 0 Then
         iframe.Range.Delete   ' delete all text in frame (including anchors)
         Selection.Delete      ' delete frame (selection leaves less residue than range)
       End If   ' end if ninlines = 0
       
       ' height or width = -1 if auto. set to small dummy that will auto adjust later
       If nheight < 0 Then nheight = 11                  ' one row is about 11 points
       If nwidth < 0 Then nwidth = InchesToPoints(3.38)  ' column width
       ' Set text to fixed width. OCR varies.
       If nwidth >= InchesToPoints(3.1) And nwidth <= InchesToPoints(3.8) Then
         nwidth = InchesToPoints(3.38)
       End If
        
       ' create new textbox
       Set iboxshape = ActiveDocument.Shapes.AddTextbox _
         (Orientation:=msoTextOrientationHorizontal, _
         Left:=nxposition - nleftmargin, Top:=nyposition - ntopmargin, _
         Width:=nwidth, Height:=nheight)
    
       ' put text in new textbox. it gets default formatting of normal style
       iboxshape.TextFrame.TextRange.Text = atext

       ' set properties for the textbox
       With iboxshape
         '  set box horizontally relative to left margin (right margin apparently does not work in VBA)
           .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
         If ax = "L" Then
           .Left = 0     ' set to left margin
         ElseIf ax = "R" Then
           .Left = npagewidth - nwidth         ' set to right margin based on left margin
           ' if not on a margin, leave horizontal as is but relative to margin. Shapes
           '  automatically handle margins
         End If
         ' set box relative to vertical margin
         .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
         If ay = "T" Then
           .Top = 0     ' set to top margin
         Else
           ' if not on top margin, leave vertical as is
           .Top = nyposition - ntopmarg
         End If
         .Line.Visible = msoFalse
       End With
       ' set spacing for words wrapping around the textbox (not used with PJ)
       With iboxshape.WrapFormat
        .Type = wdWrapFront                 ' this is important to keep objects on same page
        .DistanceTop = InchesToPoints(0)
        .DistanceBottom = InchesToPoints(0)
        .DistanceLeft = InchesToPoints(0)
        .DistanceRight = InchesToPoints(0)
       End With
       ' set margins inside text box. do not autosize now or can get overlapping
       '   boxes that put anchor for a box in a frame not yet processed
       With iboxshape.TextFrame
        .MarginBottom = 0
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
       End With
     End If  ' end if atext
     
     
   ' *** inline pictures ***  convert to drawing layer pictures. basic info obtained earlier.
   '  if process pictures before text, then some text frames end up with anchors for pictures
   '  and cannot easily delete frame and text in frame.
     If ninlines > 0 Then
       nwidth = iinline(1).Width       ' this may have been changed above
       iinline(1).ConvertToShape
       
       ' new shape will be the last one
       nshapes = iframe.Range.ShapeRange.Count
       Set ishape = iframe.Range.ShapeRange(nshapes)
       ' set properties for the picture
       With ishape
         '  set horizontally relative to left margin (right margin apparently does not work in VBA)
         .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
         If ax = "L" Then
           .Left = 0     ' set to left margin
         ElseIf ax = "R" Then
           .Left = npagewidth - nwidth         ' set to right margin based on left margin
           ' if not on a margin, leave horizontal as is but relative to margin. shapes handle margin.
         End If
         ' set relative to vertical margin
         .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
         If ay = "T" Then
           .Top = 0     ' set to top margin
         Else
           ' if not on top margin, leave vertical as is
           .Top = nyposition - ntopmarg
         End If
         ' increase picture contrast by 5% -- also converts from grayscale to color
         .PictureFormat.IncrementContrast 0.05
      End With
       ' set spacing for words wrapping around the picture
      With ishape.WrapFormat
        .Type = wdWrapFront                      ' important to keep object on page
        .DistanceTop = InchesToPoints(0.12)
        .DistanceBottom = InchesToPoints(0.12)
        .DistanceLeft = InchesToPoints(0.12)
        .DistanceRight = InchesToPoints(0.12)
      End With
    End If   ' end if ninlines > 0
  Next iloop
 End If  ' end nframes > 0
   
 If ActiveDocument.InlineShapes.Count > 0 Then
   MsgBox ("Inlineshapes left.  N=" + Str(ActiveDocument.InlineShapes.Count))
 End If
   
   
' *** cleanup frames with anchors ***  should only be frames with tables or anchors.
  ' in theory, frames with only anchors can be removed and anchors will be put on the main text layer.
  ' but in practice, the anchors and associated shapes often end up deleted or jumping around.
  ' The following clears out extraneous text in a frame and puts the frame in the left margin 3 inches
  ' from the top of the page, which reduces the jumping around. Putting the frames in the same place
  ' also combines anchors into fewer frames. any text in a non-table frame is extraneous now, so remove
  ' text. Leave paragraph markers because they may have anchors for pictures or textboxes.
  ' Attempts to delete the frames with anchors to get the anchors on the main text layer produced
  ' objects jumping to different pages.
  ' NOTE: as noted in initial comments, for reasons unknown, the programming below often deletes the
  '       text in tables unless the table is on the last page being processed.
 If ActiveDocument.Frames.Count > 0 Then
   For iloop = ActiveDocument.Frames.Count To 1 Step -1
     Set iframe = ActiveDocument.Frames(iloop)
     
     If iframe.Range.Tables.Count = 0 Then         ' skip frames with tables.
      
'      MsgBox ("iloop=" + Str(iloop) + ", nshapes=" + Str(iframe.Range.ShapeRange.Count) + _
'        ", Inlinshapes" + Str(iframe.Range.InlineShapes.Count) + ", text=" + iframe.Range.Text)
 
       ' get number of characters to delete. anchors and possibly other stuff is in the frame text
       ' but does not display or get counted in the length of the text. but, it is included when
       ' each character of the text is examined--and then appears as carriage returns (ascii 13 or vbCR).
       ' one way to figure out how many characters need to be deleted to is put the text in a string
       ' variable, which drops out the anchor stuff but keeps the text and paragraph markers.
'       idoloop = 0
       Do                             ' sometimes not all characters are deleted so loop until get them all
         iframe.Range.Select
         atext = Selection.Text
         natext = Len(atext)          ' get number of text characters
         ndel = 0                     ' count number of characters to be deleted
         nskip = 1                    ' count number of paragraph markers and other chars to skip
         If natext > 0 Then
           For i = 1 To natext                 ' check each text character
             nasc = Asc(Mid(atext, i, 1))
             If nasc <= 31 And nasc <> 9 And nasc <> 11 Then
               nskip = nskip + 1
             Else
               ndel = ndel + 1
             End If
           Next i
         End If   ' end if natext > 0
     
'         idoloop = idoloop + 1
'         MsgBox ("iloop=" + Str(iloop) + ", idoloop=" + Str(idoloop) + ", ndel=" + Str(ndel) + ", natext=" + Str(natext) + ", atext=" + atext)
     
         ' delete the characters
         If ndel > 0 Then
           iframe.Range.Select
           idel = 0
           iskip = 1                   ' number of characters to skip
           Do
             ' iskip tells how many nonprint characters are accepted and need to be skipped
             Selection.Start = iskip
             Selection.End = iskip
             ' get ascii number for the character to process easily.
             nasc = Asc(Selection.Text)
             If nasc > 31 Or nasc = 9 Or nasc = 11 Then
               Selection.Delete
               idel = idel + 1
             Else
               iskip = iskip + 1        ' skip another nonprint character
             End If
           Loop Until idel = ndel
         End If  ' end if ndel > 0
    
    '     MsgBox ("after a loop. ndel=" + Str(ndel))
       Loop Until ndel = 0
     
       ' put frame in middle of page, near left edge where any junk can be seen
       iframe.Range.Select
       iframe.HorizontalPosition = InchesToPoints(0.2)
       iframe.VerticalPosition = InchesToPoints(3)
       iframe.Width = 25
       iframe.Height = 25
     End If   ' end if no tables
   Next iloop
 End If  ' end if frames > 0
     

 ' MsgBox ("after move, frame count=" + Str(ActiveDocument.Frames.Count))

  ' set all textboxes to autosize height
  For Each ishape In ActiveDocument.Shapes
    If ishape.Type = msoTextBox Then
      ishape.TextFrame.AutoSize = True
    End If
  Next ishape

 ' move cursor to top of doc
  Selection.HomeKey Unit:=wdStory
  
  Call ObjectCounts    ' displays counts of pictures, frames, etc.

 
End Sub
Sub PageCombineNext()
'
' DeleteNextPageBreak Macro
'  Finds and deletes the next manual page break and associated paragraph marker
'
'
    
    With Selection.Find
        .Text = "^m^p"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceOne
    End With
    ' add space if not new paragraph
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    If Selection.Text <> vbCr Then
      Selection.MoveRight Unit:=wdCharacter, Count:=1
      Selection.InsertAfter (" ")
    End If


End Sub
Sub PageCombinePrevious()
'
' DeletePrevPageBreak Macro
'  Finds and deletes the previous manual page break and associated paragraph marker
'
    
    With Selection.Find
        .Text = "^m^p"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceOne
    End With
    ' add space if not new paragraph
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    If Selection.Text <> vbCr Then
      Selection.MoveRight Unit:=wdCharacter, Count:=1
      Selection.InsertAfter (" ")
    End If

End Sub
Sub GoToNextSection()
'
'
'
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^b"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute

End Sub
Sub GoToPreviousSection()
'
'
'
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^b"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    
End Sub
Sub PJ_Init1()
'
' PJ_Init1 Macro
'
'
' First step in converting ABBY FineReader docs for use with Prairie Jewels book.
' This turns off picture compression on file save, removes section breaks, and sets margins.


 Dim ntmp
 Dim iloop As Integer

 Call ObjectCounts              ' check counts of initial pictures, tables, etc.

' turn of picture compression. have to give keystrokes as not VBA procedure.
'  could not get to work reliably, so stop at dialog box and user checks and backs out.
'  make delays between keystrokes or they can get out of sequence.
'  start with a time delay of .5 second so computer can catch up with processing from hotkey
  ntmp = Timer    'Timer is time in seconds -- handles fractions
  ntmp = ntmp + 0.5
  Do While Timer < ntmp
    DoEvents      'this allows Word to finish any other processing
  Loop

' send keystrokes to turn off picture compression for file save -- best to do first for a file
  SendKeys "%f", True  ' open save as screen  "Alt-f", then "a"
  SendKeys "a", True
 
' give command to open tools button repeatedly so Word will get it when the dialog box opens.
'   repition does not hurt in this case.
  For iloop = 1 To 30
    SendKeys "%l", True
  Next
 
  SendKeys "{down}", True  ' opens list
  ntmp = Timer             ' set delay between each keystroke.
  ntmp = ntmp + 0.0002      ' if too short, miss keystroke. if too long, dialog box is displayed.
  Do While Timer < ntmp
    DoEvents
  Loop
  SendKeys "p", True       ' select Compress Pictures
  ntmp = Timer
  ntmp = ntmp + 0.0002
  Do While Timer < ntmp
    DoEvents
  Loop
  SendKeys "o", True       ' select Options
  ntmp = Timer
  ntmp = ntmp + 0.0002
  Do While Timer < ntmp
    DoEvents
  Loop
  SendKeys "-", True       ' clears the checkbox to compress pictures on save. repitition ok.
  
'  could not get following to work reliably.
'  SendKeys "{enter}", True ' exit out
'  SendKeys "{esc}", True   ' cancel out of file save
'  SendKeys "{esc}", True

' This clears the typeahead buffer, which ends up with 3 keys strokes
'  MsgBox Prompt:="Clear typeahead buffer 1"
'  MsgBox Prompt:="Clear typeahead buffer 2"
'  MsgBox Prompt:="Clear typeahead buffer 3"
'  MsgBox Prompt:="end sendkeys 4"


' -----------------------------
' Remove section breaks so only one section (rather than one for each page). also add paragraph marker
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^b"
        .Replacement.Text = "^m^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll


' ----------------------------
' set margins
    Selection.EndKey Unit:=wdStory  ' move cursor to end so not in frame or cannot set margins
    WordBasic.PageSetupMargins Tab:=0, PaperSize:=1, TopMargin:="0.9", _
        BottomMargin:="0.5", LeftMargin:="0.9", RightMargin:="0.6", Gutter:="0", _
        PageWidth:="8.5", PageHeight:="11", Orientation:=0, FirstPage:=0, _
        OtherPages:=0, VertAlign:=0, ApplyPropsTo:=4, FacingPages:=1, _
        HeaderDistance:="0", FooterDistance:="0", SectionStart:=2, _
        OddAndEvenPages:=1, DifferentFirstPage:=0, Endnotes:=1, LineNum:=0, _
        CountBy:=0, TwoOnOne:=0, GutterPosition:=0, LayoutMode:=0, DocFontName:= _
        "", FirstPageOnLeft:=0, SectionType:=1, FolioPrint:=0, ReverseFolio:=0, _
        FolioPages:=1

  ' go back to top of document
  Selection.HomeKey Unit:=wdStory


End Sub
Sub PJ_Init3()
'
' PJ_Init3 Macro
'
'
' Third step in converting ABBY FineReader docs for use with Prairie Jewels book.
' This attaches template, sets quickstyles, sets font theme, replaces tabs with spaces,
' clears bold font, and sets headers.


'---------------------------
' attach PJ template and set quickstyles
  With ActiveDocument
      .UpdateStylesOnOpen = False
      .AttachedTemplate = _
          "C:\Users\JimK\AppData\Roaming\Microsoft\Templates\pjbook.dotm"
      .XMLSchemaReferences.AutomaticValidation = True
      .XMLSchemaReferences.AllowSaveAsXMLWithoutValidation = False
  End With
  ActiveDocument.ApplyQuickStyleSet ("PJBook")
  WordBasic.ApplyQFSetTemplate

'----------------------------
' set font theme to office classic (Arial and Times New Roman) (p)
   ActiveDocument.DocumentTheme.ThemeFontScheme.Load _
  "C:\Program Files (x86)\Microsoft Office\Document Themes 12\Theme Fonts\office classic.xml"


'------------------------------
' replace tabs with a space
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
  End With
  Selection.Find.Execute Replace:=wdReplaceAll

' ------------------------
' clear straggling cases of bold font.
    
  Selection.WholeStory
  Selection.Font.Bold = False
  
' -----------------------------
' change the 1 point courier new fonts set by FineReader (for section breaks, etc) to
'  11 point new times roman
  
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Font.Size = 1
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Size = 11
    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 Replace:=wdReplaceAll

' -----------------------------
' Set headers for odd and even pages -- title and footnotes adjusted manually
 ' first need to open the template with building blocks. Load it and
 '  then find what number it is
  Templates.LoadBuildingBlocks
  Dim i, bbtemp  As Integer
  bbtemp = 0
  For i = 1 To Templates.Count
      If InStr(LCase(Templates(i).FullName), "building blocks") Then
         bbtemp = i
         Exit For
      End If
  Next
  If bbtemp = 0 Then
    MsgBox ("Could not find Template with building blocks. Exit Macro.")
    Exit Sub
  End If

  With ActiveDocument.PageSetup
     .OddAndEvenPagesHeaderFooter = True
     .HeaderDistance = InchesToPoints(0.6)
  End With
    
  If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
      ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
  End If
 
 'Go to and setup primary (odd page) header
  ActiveWindow.ActivePane.View.SeekView = wdSeekPrimaryHeader
    
   ' write dummy chapter title and page number
    Selection.ParagraphFormat.FirstLineIndent = InchesToPoints(0)
    WordBasic.InsertAlignmentTab Alignment:=1, Relative:=0, Leader:=0
    Selection.TypeText Text:="X Township"
    WordBasic.InsertAlignmentTab Alignment:=2, Relative:=0, Leader:=0
    Templates(bbtemp).BuildingBlockEntries("Plain Number"). _
        Insert Where:=Selection.Range, RichText:=True
    
   ' add the line separating from body of book
    Selection.HeaderFooter.Shapes.AddConnector(msoConnectorStraight, 62.65, _
        55.35, 504, 0.65).Select
    Selection.ShapeRange.Flip msoFlipVertical
    Selection.ShapeRange.Height = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.ConnectorFormat.Type = msoConnectorStraight
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeHorizontalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeHorizontalSize = wdRelativeHorizontalSizePage
    Selection.ShapeRange.RelativeVerticalSize = wdRelativeVerticalSizePage
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.LeftRelative = wdShapePositionRelativeNone
    Selection.ShapeRange.Top = InchesToPoints(-0.09)
    Selection.ShapeRange.TopRelative = wdShapePositionRelativeNone
    Selection.ShapeRange.WidthRelative = wdShapeSizeRelativeNone
    Selection.ShapeRange.HeightRelative = wdShapeSizeRelativeNone
    
 ' now to header for even pages
  ActiveWindow.ActivePane.View.SeekView = wdSeekEvenPagesHeader
    
   ' write dummy chapter title and page number
    Selection.ParagraphFormat.FirstLineIndent = InchesToPoints(0)
    Templates(bbtemp).BuildingBlockEntries("Plain Number"). _
        Insert Where:=Selection.Range, RichText:=True
    WordBasic.InsertAlignmentTab Alignment:=1, Relative:=0, Leader:=0
    Selection.TypeText Text:="X Township"
    
   ' add line separating from text of book
    Selection.HeaderFooter.Shapes.AddConnector(msoConnectorStraight, 43.35, _
        57.35, 504#, 2#).Select
    Selection.ShapeRange.Flip msoFlipVertical
    Selection.ShapeRange.Height = 0#
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.ConnectorFormat.Type = msoConnectorStraight
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeHorizontalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeHorizontalSize = wdRelativeHorizontalSizePage
    Selection.ShapeRange.RelativeVerticalSize = wdRelativeVerticalSizePage
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.LeftRelative = wdShapePositionRelativeNone
    Selection.ShapeRange.Top = InchesToPoints(-0.09)
    Selection.ShapeRange.TopRelative = wdShapePositionRelativeNone
    Selection.ShapeRange.WidthRelative = wdShapeSizeRelativeNone
    Selection.ShapeRange.HeightRelative = wdShapeSizeRelativeNone
    
 ' return to body of document and move cursor to top of doc
  ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  Selection.HomeKey Unit:=wdStory

' add a paragraph markers before and after each page break (for anchors)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^m"
        .Replacement.Text = "^p^m^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

' add another paragraph marker at the end of the document
  Selection.EndKey Unit:=wdStory
  Selection.InsertAfter (vbCr)

' move cursor to top of doc
  Selection.HomeKey Unit:=wdStory


End Sub
Sub PJ_Init4()
'
' PJ_Init3 Macro
'
'
' Fourth step in converting ABBY FineReader docs for use with Prairie Jewels book.
' This converts frames with text and pictures to textboxes and pictures, and then aligns
' them with the margins. Also increases contrast of pictures by 5%, which converts them
' to color (that has much less fading when converted to pdf)>
 
 Call FineReaderFrames

End Sub
Sub PJ_Init2()
'
' PJ_Init2 Macro
'
'

'--------------------------
' remove all user-created styles from the document (p)
 Call Remove_User_Styles


End Sub
Sub Para2ptBefore()
'
' Set 2 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 2
End Sub
Sub Para0ptBefore()
'
' Set 0 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 0
End Sub

Sub Para3ptBefore()
'
' Set 3 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 3
End Sub
Sub Para4ptBefore()
'
' Set 4 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 4
End Sub
Sub Para6ptBefore()
'
' Set 6 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 6
End Sub
Sub Para9ptBefore()
'
' Set 9 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 9
End Sub
Sub Para12ptBefore()
'
' Set 12 pt spacing before paragraph
'
'
    Selection.Paragraphs.SpaceBefore = 12
End Sub

Sub ParaPlus6ptBefore()
'
' Add 6 pt to spacing before the paragraph
'
    Selection.Paragraphs.SpaceBefore = (Selection.Paragraphs.SpaceBefore) + 6
End Sub
Sub para_combine()
'
' combines paragraphs or lines separated with manual line breaks. finds next paragraph marker or
'  manual line break, whichever is first, and replaces with a space.
'
'
    ' if on a paragraph marker or manual return, move left one char so will get it in find.
    ' vbCr = ascii 13=paragraph marker, ascii 11=manual return
    If Selection.Text = vbCr Or Selection.Text = Chr(11) Then
      Selection.MoveLeft Unit:=wdCharacter, Count:=1
    End If
    
    ' select to end of paragraph
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    ' search within the selected paragraph for a manual return (^l)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^l"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    isfound = Selection.Find.Execute

    If isfound = True Then
      ' Delete manual return and put in a space
      Selection.Delete
      Selection.InsertAfter (" ")
    Else
      ' find and remove paragraph marker (re-finding avoids problems if end of doc)
      With Selection.Find
        .Text = "^p"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceOne
      End With
      ' add space if not at another end of line marker
      If Selection.Text <> vbCr And Selection.Text <> Chr(11) Then
        Selection.InsertAfter (" ")
      End If
    End If
      
    
End Sub
Sub AutoOpen()
'
' AutoOpen Macro    display file name with path in Word title bar for files that exist.
'
'
ActiveDocument.ActiveWindow.Caption = ActiveDocument.FullName
End Sub
Sub ObjectCounts()
'
' ObjectCounts Macro
'   Displays counts of frames, inline pictures, shape pictures and textboxes, etc.
'

  Dim nshapepic, nshapetext, nshapetab, nshapeother, ninlinepic, ninlineother, nframe, _
      nfshapepic, nfshapetext, nfshapetab, nfshapeother, nfinlinepic, nfinlineother, _
      nftables, nfmultiple, nfnone, nftext, nshapes, nframes, ninlines, ntables As Integer
  Dim ishape As Shape
  Dim iframe As frame
  Dim iinline As InlineShape

  nshapes = ActiveDocument.Shapes.Count
  nframes = ActiveDocument.Frames.Count
  ninlines = ActiveDocument.InlineShapes.Count
  ntables = ActiveDocument.Tables.Count
  
  If nshapes > 0 Then
    For Each ishape In ActiveDocument.Shapes
      If ishape.Type = msoPicture Or ishape.Type = msoLinkedPicture Then
        nshapepic = nshapepic + 1
      ElseIf ishape.Type = msoTextBox Then
        nshapetext = nshapetext + 1
      ElseIf ishape.Type = msoTable Then
        nshapetab = nshapetab + 1
      Else
        nshapeother = nshapeother + 1
      End If
    Next ishape
  End If  ' end if nshapes > 0
  
  If ninlines > 0 Then
    For Each iinline In ActiveDocument.InlineShapes
      If iinline.Type = wdInlineShapePicture Or iinline.Type = wdInlineShapeLinkedPicture Then
        ninlinepic = ninlinepic + 1
      Else
        ninlineother = ninlineother + 1
      End If
    Next iinline
  End If  ' end if iinlines > 0
  
  If nframes > 0 Then
    For Each iframe In ActiveDocument.Frames
      If iframe.Range.ShapeRange.Count > 0 Then
        For Each ishape In iframe.Range.ShapeRange
          If ishape.Type = msoPicture Or ishape.Type = msoLinkedPicture Then
            nfshapepic = nfshapepic + 1
          ElseIf ishape.Type = msoTextBox Then
            nfshapetext = nfshapetext + 1
          ElseIf ishape.Type = msoTable Then
            nfshapetab = nfshapetab + 1
          Else
            nfshapeother = nfshapeother + 1
          End If
        Next ishape
      End If   ' end if iframe shapes > 0
      
      If iframe.Range.InlineShapes.Count > 0 Then
        For Each iinline In iframe.Range.InlineShapes
          If iinline.Type = wdInlineShapePicture Or iinline.Type = wdInlineShapeLinkedPicture Then
            nfinlinepic = nfinlinepic + 1
          Else
            nfinlineother = nfinlineother + 1
          End If
        Next iinline
      End If   ' end if iframe inlineshapes > 0
      
      If iframe.Range.Tables.Count > 0 Then
        nftables = nftables + 1
      End If
      
      If iframe.Range.ShapeRange.Count + iframe.Range.InlineShapes.Count + _
          iframe.Range.Tables.Count > 1 Then
        nfmultiple = nfmultiple + 1
      ElseIf iframe.Range.ShapeRange.Count + iframe.Range.InlineShapes.Count + _
          iframe.Range.Tables.Count = 0 Then
        nfnone = nfnone + 1
      End If
      
      If Len(iframe.Range.Text) > 3 And iframe.Range.Tables.Count = 0 Then
        nftext = nftext + 1
'       MsgBox ("Frame with text. Text=" & iframe.Range.Text)
      End If
      
    Next   ' next iframe
  
    
  
  End If  ' end if nframes > 0
  
  MsgBox ("N Shape Pictures=" + Str(nshapepic) + ",  " + Str(nfshapepic) + " in Frames" + vbCr + _
          "N Shape Textboxes=" + Str(nshapetext) + ", " + Str(nfshapetext) + " in Frames" + vbCr + _
          "N Shape Tables=" + Str(nshapetab) + ", " + Str(nfshapetab) + " in Frames" + vbCr + _
          "N Shape Other=" + Str(nshapeother) + ", " + Str(nfshapeother) + " in Frames" + vbCr + _
          "N InlineShape Pictures=" + Str(ninlinepic) + ", " + Str(nfinlinepic) + " in Frames" + vbCr + _
          "N InlineShape Other=" + Str(ninlineother) + ", " + Str(nfinlineother) + " in Frames" + vbCr + _
          "N Text Tables=" + Str(ntables) + ", " + Str(nftables) + " in Frames" + vbCr + _
          "N Frames=" + Str(nframes) + ", " + Str(nfmultiple) + " with multiple objects, " + _
          Str(nfnone) + " with no objects" + vbCr + _
          "N Frames with text=" + Str(nftext))

End Sub
Sub PJ_Init5()
'
' set some format properties for tables. make rows expand with content, set
'  paragraph properties, and make first line bold. This is typical for the
'  list or table of post offices in PJ.

 Dim itable As Table
  
 If ActiveDocument.Tables.Count > 0 Then
   For Each itable In ActiveDocument.Tables
     itable.Select
     Selection.Rows.HeightRule = wdRowHeightAtLeast
     Selection.Rows.Height = InchesToPoints(0.1)
     With Selection.ParagraphFormat
        .LeftIndent = InchesToPoints(0)
        .RightIndent = InchesToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft
        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = InchesToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
     End With
     itable.Rows(1).Select
     Selection.Font.Bold = True
   Next itable
 End If   ' end if tables > 0
 
 ' put curosr on first table
 Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst
   
End Sub
Sub ManualReturenToSpace()
'
' ManualReturenToSpace Macro
'
'
' Replace manual return with a space
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^l"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

End Sub
Sub PJ_Init6_map()
'
'  Locates and centers township map and adds text 1884 Atlas.
'  Must have map selected or get error message.
'
'
    
    If Selection.ShapeRange.Count = 0 Then
      MsgBox ("Need to Select Map")
    Else
      Set ishape = Selection.ShapeRange(1)
      If ishape.Width < InchesToPoints(6) Or ishape.Height < InchesToPoints(8) Then
         MsgBox ("Need to Select Map (Size too small)")
         Exit Sub
      End If
      ' locate and center map -- already set to be relative to margins
      ishape.Left = wdShapeCenter
      ishape.Top = InchesToPoints(0.9)
      ' add 1884 Atlas above map
      Selection.HomeKey Unit:=wdStory
      Selection.MoveUp Unit:=wdLine, Count:=3
      Selection.TypeParagraph
      Selection.TypeText Text:="1884 Atlas"
      Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End If
    
End Sub
Sub ManualReturnToParagr()
'
' ManualReturnToParagr Macro
'
'
'   finds next manual return and replaces it with a paragraph marker
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^l"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceOne
    Selection.MoveRight Unit:=wdCharacter, Count:=1

End Sub