none
Word 2010 Macro to resize inlineshapes randomly stops resizing images. RRS feed

  • Question

  •   I have a word macro that amongst other things resizes the inlineshapes in the document to be 100% by 100%.  This works sometimes and doesn't work at others.  All other functions of the macro continue to work, just the resizing seems to sometimes stop working.  Sometimes it will resize all the images, sometimes none and sometimes it will get half way and then the rest of the images will not have been resized.  I cannot seem to find a pattern or way to consistently replicate the problem.  I have tried both of these bits of code, both with the same results.

        For Each iShape In ActiveDocument.Shapes
                    iShape.ScaleHeight = 100
                    iShape.ScaleWidth = 100
        Next

    Tried this alternative which does the same thing:

        Dim iShapeCount As Integer
        For iShapeCount = ActiveDocument.InlineShapes.Count To 1 Step -1
            ActiveDocument.InlineShapes(iShapeCount).ScaleHeight = 100
            ActiveDocument.InlineShapes(iShapeCount).ScaleWidth = 100
        Next iShapeCount

    Has anyone run into a situation like this before?

    Wednesday, July 22, 2015 5:54 PM

All replies

  • Your first loop won't process any inlineshapes, as it references ActiveDocument.Shapes. Not only that, but using ScaleHeight = 100 for a Shape object would resize it to 100 times the original! Assuming you're actually working with inlineshapes, your other macro won't resize any for which the metadata indicates that's already the scaling (e.g. that was it's original size or it's been compressed). Finally, if the aspect ratio has been locked after the image has had it changed from the original, changing the scaling of either or both dimensions won't change that and resetting both in sequence will only result in the last-set dimension being 100%.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Wednesday, July 22, 2015 11:11 PM
  •   Thanks for your reply Paul.  I did make a typo there, I was using ActiveDocument.InlineShapes not .Shapes.  I see what you are saying but I still don't get why it works sometimes and not others.  I guess I didn't say this in my original post but I am testing this on the same document and sometimes it resizes the images to 100% by 100% and other times it doesn't.  There doesn't seem to be any disernable pattern as to why it will work one time and not work the second time (with an original copy of the document).

    Thursday, July 23, 2015 2:59 PM
  • Hi Ben

    Could you share the document on OneDrive or similar so that we can look at it and test, also?

    Doe the behavior occur with other documents of similar content, or only this one?

    Which version of Word are we dealing with?


    Cindy Meister, VSTO/Word MVP, my blog

    Thursday, July 23, 2015 4:21 PM
    Moderator
  • Hi Ben,

    Could you reproduce that issue in a new file?

    Regards

    Starain


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, July 24, 2015 1:31 AM
    Moderator
  • Unfortunately I am in a pretty locked down environment and can't upload to onenote.  The same results happen (and sometimes don't happen) on any file.  Using Word 2010.  The Macro does quite a few things and it all works consistently with the exception of the image resizing.  The macro is pretty long and even though it seems to be less than the maximum character count msdn won't let me post it here.

     
    Tuesday, July 28, 2015 4:47 PM
  • Hi Ben,

    Do you mean you can’t upload the same file on the OneDrive?

    For long macro code, you may split it in multiple replies.

    Regards

    Starain


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Wednesday, July 29, 2015 2:49 AM
    Moderator
  • Unfortunately I am in a pretty locked down environment and can't upload to onenote.  The same results happen (and sometimes don't happen) on any file.  Using Word 2010.  The Macro does quite a few things and it all works consistently with the exception of the image resizing.  The macro is pretty long and even though it seems to be less than the maximum character count msdn won't let me post it here.

     

    Hi Ben

    The fact that the problem only crops up now and then and is not 100% reproducible is going to make tracking it down extremely difficult. In your place, I'd probably start looking at the order in which things can happen. If the code is complex is it possible that things don't always happen in the same order? Or that sometimes something is done and other times not? Would there be any way for you to put the resizing at the very end - and be sure it's always the last thing done?


    Cindy Meister, VSTO/Word MVP, my blog

    Wednesday, July 29, 2015 2:23 PM
    Moderator
  • I can't upload any file to OneNote, but it doesn not surprise me due to our environment here.  Cindy, I have tried that, putting it in different places, trying to make it the last thing that happens, with no change.
    Wednesday, July 29, 2015 2:35 PM
  • Sub Format_ALM_Document()
      ' This macro determines what type of processing to do on the document.
      '
      ' The macro looks for a merged field value in the generated that starts with "<UseMacro>". Such a value is created using the merged field formula shown below:
      '    "{ MERGEFIELD  Macro \b <UseMacro>  \* MERGEFORMAT }"
      '
      ' If the merged field doesn't exist, default processing is done.
      '
    
        Dim macroSearchText, macroToUse As String
        macroSearchText = "<UseMacro>"
        macroToUse = ""
        
        ' Find the merged field
        Selection.HomeKey wdStory
        Selection.Find.ClearFormatting
        
        ' It's important to keep all these settings in the With block as they are set. If removed,
        ' the macro won't find the proper keyword because wildcards or formatting might be on.
        With Selection.Find
            .Text = macroSearchText
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        
        ' If it exists, get the macro value
        If Selection.Find.Execute = True Then
            
            Selection.EndKey Extend:=wdExtend        ' Select the whole line
            
            ' Remove the marker text to isolate the macro value and the trailing carriage return
            macroToUse = Replace(Replace(Selection.Text, macroSearchText, ""), Chr(13), "")
        
        End If
          
        ' Reset the cursor position to the top of the document
        Selection.HomeKey Unit:=wdStory
        
        Select Case macroToUse
        
             Case "FCB"
                Macro_FCB
                
            Case "IMP"                                'Added for Implementation Documents
                Macro_IMP
                
            Case Else
                Macro_Default
        
        End Select
        
    End Sub
    Private Sub Macro_Default()
    
            'This macro is used to clean up formatting issues with the documents that are generated by HP ALM
        
        Dim StartTime
        Dim EndTime
        Dim ElapsedTime
        Dim vStyle
           
        StartTime = Timer    ' Set start time.
    
        'Hide the "white space" between page boundary header/footer areas because this can interfere with certain commands
        '       (e.g. when we delete an 'empty' paragraph that spills over onto the next page, it deletes too many characters)
        With ActiveWindow.View
            .Type = wdPrintView
            .DisplayPageBoundaries = False
        End With
            
        'Determine the available page width based on margin sizes  (there are 612 points available in 8.5 in page)
        vLeftMargin = Application.ActiveDocument.PageSetup.LeftMargin
        vRightMargin = Application.ActiveDocument.PageSetup.RightMargin
        vPageWidth = 612 - vLeftMargin - vRightMargin
        
        'Find the first page after the table of contents to start the formatting
        Selection.HomeKey Unit:=wdStory
        Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1, Name:="TOC"
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
        
        'Select from the cursor position to the end of the document
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        
        Set vSelection = Selection.Range
        'Ensure that we are using the proper font and color (HP ALM might be adjusting some of these?)
        Selection.Range.Font.Name = "Verdana"
        'Selection.Range.Font.ColorIndex = wdAuto    Maybe we shouldn't override font colour??
        Selection.Range.SpellingChecked = True
        Selection.LanguageID = wdEnglishCanadian
        Selection.NoProofing = False
        Application.CheckLanguage = True
                 
        numpar = Selection.Range.Paragraphs.Count
        Selection.HomeKey Unit:=wdLine
       
        ActiveWindow.View.Type = wdNormalView
        'Flag to indicate that we want to remove parent headings with no unique ID
        bRemoveEmptyHeadings = True
        vOffsetHdg = 0
        'Loop through each paragraph
        For i = 1 To numpar
            'Extend to the end of the current paragraph and count the number of characters within it
            Selection.MoveEnd Unit:=wdParagraph
            nChars = Selection.Range.Characters.Count
        
            Set vRange = Selection.Range        'Get a copy of the current selection object - used for debugging purposes
                    
            vStyle = Selection.Range.Style
                   
            'Clean up any leading spaces in the headings
            If InStr(vStyle, "Heading") > 0 Then
                
                'New Jan 25/13
                'Look for headings that do not have a unique ID - indicates that they are simply a parent in the hierarchy and can be deleted
                If IsNumeric(Mid(vStyle, 9)) Then
                    If bRemoveEmptyHeadings And InStr(Selection.Range.Text, "()") > 0 Then
                        vOffsetHdg = Int(Mid(vStyle, 9))
                        Selection.Delete
                        Selection.MoveEnd Unit:=wdParagraph
                        nChars = Selection.Range.Characters.Count
                        'Increment the loop counter to account for the number of paragraphs that have been deleted
                        i = i + 1
        
                    Else
                        'NEW
                        If vOffsetHdg > 0 Then
                            vCurrentHdg = Int(Mid(vStyle, 9))
                            Selection.Range.Style = "Heading " & (vCurrentHdg - vOffsetHdg)
                            bRemoveEmptyHeadings = False
                        End If
                    End If
                        '------- end of new Jan 25/13
                    
                    If Left(Selection.Range.Text, 2) = "  " Or Left(Selection.Range.Text, 2) = ": " Then
                        Selection.HomeKey Unit:=wdLine
                        Selection.Delete Unit:=wdCharacter, Count:=1
                        Selection.Delete Unit:=wdCharacter, Count:=1
                    End If
                    
                    'Capture the indent level of each heading so that we can align following text to it
                    If InStr(vStyle, "ALM_Attachment_Heading") > 0 Then
                        'If the LeftIndent is 0 (e.g. for special 'ALM_Attachment_Heading'), and an extra indent to simulate a heading
                        'This is done so that we don't have the attchment headng showing up in the table of contents
                        Selection.Range.ParagraphFormat.LeftIndent = vIndent
                        vIndent = vIndent + 12
                    Else
                        vIndent = Selection.Range.ParagraphFormat.LeftIndent
                    End If
                
                End If
                
            End If
            
            'Detect if we are in a table
            If Selection.Information(wdWithInTable) = True Then
                Selection.Tables(1).Select
                vLen1 = 0
                vLen2 = 0
                vFirstCellStyle = ""
                bEmptyTable = False
                vParagraphCount = Selection.Tables(1).Range.Paragraphs.Count
    
                'Check to see if this table is a requirement header table coming from ALM (check style name)
                vFirstCellStyle = Selection.Tables(1).Cell(1, 1).Range.Style
                If vFirstCellStyle = "ALM_Header_Table" Then
                            
                    'Delete any tables that have this special style, but only if they have a 'Status' column and no value in the adjoining column
                    vFirstCell = Selection.Tables(1).Rows(1).Cells(1).Range.Text
                    vLen1 = Len(vFirstCell)
                    vFirstCellContents = Left(vFirstCell, (vLen1 - 2))
                    vSecondCell = Selection.Tables(1).Rows(1).Cells(2).Range.Text
                    vLen2 = Len(vSecondCell)
                    vSecondCellContents = Left(vSecondCell, (vLen2 - 2))
                    
                    If (vSecondCellContents = "") Then
                        bEmptyTable = True
                    End If
                    
                End If
                          
                If bEmptyTable Then
                    Selection.Tables(1).Delete
                    Selection.MoveUp Unit:=wdParagraph
                                            
                    'Increment the loop counter to account for the number of paragraphs that have been deleted
                    i = i + (vParagraphCount - 2)
                
                Else
                    'Reformat the table to ensure that any 'adjustments' that are made by ALM do not distort the table too much
    
                    'Set oTable = Selection.Tables(1)       'For debugging purposes
                                
                    'Remove any before/after spacing in the paragraphs
                    With Selection.ParagraphFormat
                        .SpaceBefore = 0
                        .SpaceBeforeAuto = False
                        .SpaceAfter = 0
                        .SpaceAfterAuto = False
                    End With
                
                    'Add a little bit of cell padding on all cells (applied at the table level)
                    With Selection.Tables(1)
                        .TopPadding = CentimetersToPoints(0.05)
                        .BottomPadding = CentimetersToPoints(0.05)
                        .LeftPadding = CentimetersToPoints(0.1)
                        .RightPadding = CentimetersToPoints(0.1)
                        .Spacing = 0
                        .AllowPageBreaks = True
                        .AllowAutoFit = True
                    End With
                                
                    'Remove any defined row height (to keep tables compact)
                    With Selection.Tables(1).Rows
                        .HeightRule = wdRowHeightAuto
                        .AllowBreakAcrossPages = False      'Rows msut be kept on the same page
                    End With
                    
                    'Ensure that the first row in any table is kept with the following row (to prevent 'orphan headers)
                    Selection.Tables(1).Cell(1, 1).Range.ParagraphFormat.KeepWithNext = True
                    
                    numCols = 0
                    iTableWidth = 0
                    iRow = 0
                    Do While iRow < 2
                    'Calculate the number of columns in the first row
                        iRow = Selection.Tables(1).Range.Cells(numCols + 1).RowIndex
                        If iRow = 1 Then
                            numCols = numCols + 1
                            iTableWidth = iTableWidth + Selection.Tables(1).Range.Cells(numCols).Width
                            
                            vOrientation = Selection.Tables(1).Range.Cells(numCols).Range.Orientation
                            If vOrientation > 0 Then        'Anything greater that 0 means that the text is rotated
                                If Selection.Tables(1).Range.Cells(numCols).Range.Characters.Count > NumRotatedChars Then
                                    NumRotatedChars = Selection.Tables(1).Range.Cells(numCols).Range.Characters.Count
                                End If
                            End If
                        End If
                        
                        'Exit if there is only one row
                        If numCols = Selection.Tables(1).Range.Cells.Count Then
                            Exit Do
                        End If
                    Loop
    
                    'Calculate the row height needed to display the rotated text (5.4 points is about 0.2 cm)
                    If NumRotatedChars > 0 Then
                        Selection.Tables(1).Cell(1, 1).Height = NumRotatedChars * 5.4
                    End If
    
    
                    'Set the indent of the table to match the current positioning
                    Selection.Tables(1).Rows.LeftIndent = vIndent
                    
                    'Resize the table if the width is greater than the available page width
                    If iTableWidth > (vPageWidth - vIndent) Then
                        Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
                        Selection.Tables(1).PreferredWidth = (vPageWidth - vIndent)
                    End If
                    
                    Selection.MoveRight
             
                    'Increment the loop counter to account for the number of paragraphs that have been skipped
                    i = i + vParagraphCount
                     
                    bPreviousTable = True
                     
                End If
                    
                'Format an empty paragraph after the table to ensure that we don't merge any following tables together
                 If Not bEmptyTable Then
                    Selection.TypeText Text:="  "
                    Selection.TypeParagraph
                    Selection.MoveUp Unit:=wdLine, Count:=1
                    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                   
                    With Selection.ParagraphFormat
                        .SpaceBefore = 0
                        .SpaceBeforeAuto = False
                        .SpaceAfter = 0
                        .SpaceAfterAuto = False
                        .LineSpacingRule = wdLineSpaceSingle
                    End With
                    Selection.Font.Size = 4
                
                Else
                 ' Selection.MoveLeft      '??? try for ALM header
    
                End If
        
            Else            'Not in a table
                'Delete any paragraphs that are less than 4 chars long (to eliminate empty lines, and lines with just line breaks)
                If nChars < 4 Then
                    If Selection.InlineShapes.Count = 0 Then
                        'Feb 25 2013 - If the paragraph has some non-blank characters and there is table following
                        '               and we delete the section, a paragraph remains - so first clear out the chars?
                        Selection.HomeKey Unit:=wdLine
                        For j = 1 To nChars
                            Selection.Delete Unit:=wdCharacter, Count:=1
                        Next
    
                       ' Selection.Delete
                        Selection.MoveUp Unit:=wdParagraph
                    Else
                        'Image detected
                        Selection.Range.ParagraphFormat.LeftIndent = vIndent
    
                        'Resize the image if it is greater than the page width
                        vImageWidth = vPageWidth - vIndent
                        Selection.InlineShapes.Item(1).LockAspectRatio = msoTrue
                        If Selection.InlineShapes.Item(1).Width > vImageWidth Then
                            Selection.InlineShapes.Item(1).Height = vImageWidth * (Selection.InlineShapes.Item(1).Height / Selection.InlineShapes.Item(1).Width)
                            Selection.InlineShapes.Item(1).Width = vImageWidth
                        End If
    
                    End If
               
                'Processing for 'regular' paragraphs
                Else
                
                    'Force the font size to 10 for those that are currently set to 8 (not sure why this is happening, but we can clean it up here)
                    '   (but not for lists)
                    If Selection.Range.Font.Size = 8 Then
                        Selection.Range.Font.Size = 10      '**** Still needed???
                    End If
                                        
                    'Non-list paragraphs and not heading (e.g. normal text)
                    If Selection.Range.ListParagraphs.Count = 0 Then
                        If InStr(vStyle, "Heading") = 0 Then
                            
                            'Align text to the indent of the latest heading
                            If Selection.Range.ParagraphFormat.FirstLineIndent = 0 Then
                                Selection.Range.ParagraphFormat.LeftIndent = vIndent
                            Else
                                'If there is a hanging indent, then we need to add the value of that hanging indent (multiplied by -1 because it is a negative value) to the LeftIndent value
                                Selection.Range.ParagraphFormat.LeftIndent = vIndent + (Selection.Range.ParagraphFormat.FirstLineIndent * -1)
                            End If
                            
                            'Remove direct formatting that would be coming from copy/paste actions in rich text fields
                            If Selection.Range.ParagraphFormat.SpaceBefore = 0 Then
                                Selection.Range.ParagraphFormat.SpaceBefore = 6
                            End If
                            
                            If Selection.Range.ParagraphFormat.SpaceAfter = 0 Then
                                Selection.Range.ParagraphFormat.SpaceAfter = 6
                            End If
                            
                        End If
                    Else
                        'Different formatting for lists
                        With Selection.Range.ParagraphFormat
                            .SpaceBefore = 3
                            .SpaceBeforeAuto = False
                            .SpaceAfter = 3
                            .SpaceAfterAuto = False
                        End With
                        
                        vListLevel = Selection.Range.ListFormat.ListLevelNumber
                                 
                        'Detect and indent nested lists
                        Selection.Range.ParagraphFormat.LeftIndent = vIndent + (vListLevel - 1) * 15
                        Selection.Range.ListParagraphs(1).FirstLineIndent = 0
                        Selection.Range.ListParagraphs(1).TabStops(1).Position = vIndent + 15
                        Selection.Range.ListParagraphs(1).TabStops(2).Position = vIndent + 30
    

    Wednesday, July 29, 2015 2:36 PM
  •                     Selection.Range.ListParagraphs(1).TabStops(3).Position = vIndent + 45
                        Selection.Range.ListParagraphs(1).TabStops(4).Position = vIndent + 60
                        Selection.Range.ListParagraphs(1).TabHangingIndent (1)
                    End If
                End If
                
           End If
                
            'Jump to next paragraph
            Selection.MoveDown Unit:=wdParagraph
            
            'Just a placeholder to set a breakpoint when we are getting near the end of the document (for debugging purposes)
            If (numpar - i) < 10 Then
                a = 1
            End If
                    
            If IsNull(Selection.Range.NextStoryRange) Then
                Exit For
            End If
            
            DoEvents
            
            
        Next
    
        FinishTime = Timer    ' Set end time.
        TotalTime = FinishTime - StartTime    ' Calculate total time.
    
        'Update the TOC to reflect the changes in style and page numbers
        If Application.ActiveDocument.TablesOfContents.Count > 0 Then
            Application.ActiveDocument.TablesOfContents(1).Update
            Application.ActiveDocument.TablesOfContents(1).UpdatePageNumbers
        
            'Update the table of contents (ensure that there is no spacing between entries)
            Selection.HomeKey Unit:=wdStory
            Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1, Name:="TOC"
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        
            With Selection.ParagraphFormat
                .SpaceBefore = 0
                .SpaceBeforeAuto = False
                .SpaceAfter = 0
                .SpaceAfterAuto = False
                .LineSpacingRule = wdLineSpaceSingle
            End With
        
        End If
        
        'Replace any remaining ()'s left by levels with no Unique ID
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "()"
            .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
        
        'Reformat the page footer with the nunmber of pages remaining
        ActiveDocument.Sections(ActiveDocument.Sections.Count) _
            .Footers(wdHeaderFooterPrimary).Range.Select
        With Selection
            .Paragraphs(1).Alignment = wdAlignParagraphCenter
            .TypeText Text:="Page "
            .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "PAGE ", PreserveFormatting:=True
            .TypeText Text:=" of "
            .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "NUMPAGES ", PreserveFormatting:=True
        End With
        
        If ActiveWindow.View.SplitSpecial = wdPaneNone Then
            ActiveWindow.ActivePane.View.Type = wdPrintView
        Else
            ActiveWindow.View.Type = wdPrintView
        End If
        
        'Find the first page after the table of contents
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
           
    MsgBox "Done!  Completed " & numpar & " paragraphs in " & Round(TotalTime, 0) & " seconds)"
    
    End Sub
    Private Sub Macro_FCB()
    
      ' This sub is used to clean up formatting issues for FCB documents coming out of HP ALM.
      '
      ' The macro has the following dependences:
      '   - It assumes the following templates are being used:
      '       - FCB Enhancement Document Template.docx
      '       - FCB Styles.docx
      '       - FCB Rich Text Only Section Template.docx
      '       - FCB Enhancement Content.docx
      '       - FCB Attachment Template.docx
      '   - If a parent artifact has a unique ID, all of it's children must have a unique ID (no blanks). If it's blank, it will fail when trying to apply the heading style.
      '
      
        On Error GoTo ErrorHandler
        
        Dim StartTime
        Dim EndTime
        Dim ElapsedTime
            
        StartTime = Timer
        
        Dim breakMarkerFound As Boolean
        breakMarkerFound = True
        
        Selection.HomeKey Unit:=wdStory
        
        ' Search for the section break placeholder in the template
        While breakMarkerFound = True
        
            Selection.Find.ClearFormatting
            With Selection.Find
                .Text = "<SectionBreak>" & Chr(13)
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
                   
           breakMarkerFound = Selection.Find.Execute
           
           ' For each one found, replace with an actual section break
           If breakMarkerFound = True Then
                Selection.Delete
                Selection.InsertBreak Type:=wdSectionBreakNextPage
            End If
            
        Wend
       
        ' Go to the TOC section, disconnect it from the title page and put Page i of i at the bottom
        ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
        ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary).Range.Select
        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        Selection.TypeText Text:="Page "
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="PAGE \* roman ", PreserveFormatting:=True
        Selection.TypeText Text:=" of "
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="SECTIONPAGES \* roman ", PreserveFormatting:=True
        
        ' Go to the Content section, disconnect it from the TOC section and put Page 1 of 1 at the bottom
        ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
        ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Range.Select
        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        Selection.TypeText Text:="Page "
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="PAGE ", PreserveFormatting:=True
        Selection.TypeText Text:=" of "
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="SECTIONPAGES ", PreserveFormatting:=True
        
        ' Disconnect all Headers from the Title Page
        ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
        
        ' Delete the Header and Footer content of the Title Page
        ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete
        ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Delete
        
        ' Position the cursor at the beginning of the document
        ActiveDocument.Paragraphs(1).Range.Select
        Selection.HomeKey Unit:=wdStory
        
        ' Change it to Normal View, because it runs faster in this view
        ActiveWindow.View.Type = wdNormalView
        
        ' Remove weird circles followed by two paragraphs (junk added by ALM), do it twice just to make sure we catch everything
        For Count = 1 To 2
            
            Selection.WholeStory
            
            With Selection.Range.Find
                .Text = Chr(160) & Chr(160) & Chr(13) & Chr(13) ' weird space x 2 + paragraph
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
                .Execute Replace:=wdReplaceAll
            End With
            
        Next
        
        Selection.WholeStory
        
        ' Remove extra carriage return that was marked with a special string in the template ("$.$(space)")
        With Selection.Range.Find
            .Text = "$.$ " & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
    
        Selection.WholeStory
    
        ' Remove extra carriage return that was marked with a special string in the template ("$.$")
        With Selection.Range.Find
            .Text = "$.$" & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Do another search for "$.$ " without the carriage return because if the string is before a table the above Find/Replace commands do not remove it for some reason
        With Selection.Range.Find
            .Text = "$.$ "
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Do another search for "$.$" without the carriage return because if the string is before a table the above Find/Replace commands do not remove it for some reason
        With Selection.Range.Find
            .Text = "$.$"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
    
        Dim para As Paragraph
        Dim lastPara As Paragraph
        Dim paraStyle As Style
        Dim currentHeadingLevel As Integer
        Dim headingOffset As Integer
        Dim listLevel As Integer
        Dim listStringValue As String
        
        Dim justEntered As Boolean   ' flag to keep track of when we just enter a table or are on an image
        justEntered = True
                
        ' Reset picture sizes to be 100% by 100%
        For Each Pic In ActiveDocument.InlineShapes
            Pic.ScaleHeight = 100
            Pic.ScaleWidth = 100
        Next
            
                
        ' Loop through each paragraph and process it
        For Each para In ActiveDocument.Paragraphs
        
            para.Range.Select
           
            ' If we're in a table or on an image, fomat the paragraph directly above it to Keep with Next (additional table processing is done later in the macro)
            If para.Range.Information(wdWithInTable) = True Or para.Range.InlineShapes.Count > 0 Then
                
                If justEntered = True Then
                    justEntered = False
                    
                    ' If we're not just on an empty paragraph, format it
                    If lastPara.Range.Text <> Chr(13) Then
                        lastPara.KeepWithNext = True
                        lastPara.SpaceAfter = 6
                    End If
                    
                End If
                
                ' Are we in a list?
                If para.Range.ListParagraphs.Count > 0 Then
                    
                    listStringValue = para.Range.ListFormat.ListString
                            
                    ' Lists that are numbers or letters have a "." in them (i.e. "1." or "a.")
                    If InStr(listStringValue, ".") > 0 Then
                            
                        'Different formatting for numbered and lettered lists
                        With para.Range.ParagraphFormat
                            .SpaceBefore = 0
                            .SpaceBeforeAuto = False
                            .SpaceAfter = 0
                            .SpaceAfterAuto = False
                        End With
                                
                    Else
                            
                        'Different formatting for bulleted lists
                        With para.Range.ParagraphFormat
                            .SpaceBefore = 3
                            .SpaceBeforeAuto = False
                            .SpaceAfter = 3
                            .SpaceAfterAuto = False
                        End With
                        
                    End If
                            
                    listLevel = para.Range.ListFormat.ListLevelNumber
                    
                    'Detect and indent nested lists
                    para.Range.ParagraphFormat.LeftIndent = (listLevel - 1) * 15
                    para.Range.ListParagraphs(1).FirstLineIndent = 0
                    para.Range.ListParagraphs(1).TabStops(1).Position = 15
                    para.Range.ListParagraphs(1).TabStops(2).Position = 30
                    para.Range.ListParagraphs(1).TabStops(3).Position = 45
                    para.Range.ListParagraphs(1).TabStops(4).Position = 60
                    para.Range.ListParagraphs(1).TabHangingIndent (1)
                        
                Else
                     
                    ' The paragraph is normal text
                    With para.Range.ParagraphFormat
                        .SpaceBefore = 0
                        .SpaceBeforeAuto = False
                        .SpaceAfter = 0
                        .SpaceAfterAuto = False
                    End With
                        
                End If
            
            Else
            
                justEntered = True     ' reset the table flag
                Set lastPara = para
                Set paraStyle = para.Range.Style
                        
                ' If the paragraph is a heading....
                If InStr(paraStyle, "Heading") > 0 And IsNumeric(Mid(paraStyle, 9)) Then
               
                    ' If it's a heading without an ID, remove it
                    If InStr(para.Range.Text, "()") > 0 Then
                        headingOffset = Mid(paraStyle, 9)
                        para.Range.Delete
                    Else
        
                        ' Adjust the heading
                        currentHeadingLevel = Mid(paraStyle, 9)
                        para.Range.Style = "Heading " & (currentHeadingLevel - headingOffset)
                        para.Range.ParagraphFormat.KeepWithNext = True
                        
                        ' Add a page break to the beginning if it's the beginning of the Technical Design section
                        If InStr(para.Range, "Technical Design") Then
                            Selection.HomeKey Unit:=wdLine
                            Selection.InsertBreak Type:=wdPageBreak
                        End If
                        
                    End If
            
                Else
            
                    ' if the paragraph is an empty paragraph added by ALM, remove it
                    If para.Range.Text = Chr(13) And para.Range.ParagraphFormat.SpaceAfterAuto = -1 Then
                        para.Range.Delete
                    
                    Else
                    
                        ' Are we in a list?
                        If para.Range.ListParagraphs.Count > 0 Then
                        
                            listStringValue = para.Range.ListFormat.ListString
                            
                            ' Lists that are numbers or letters have a "." in them (i.e. "1." or "a.")
                            If InStr(listStringValue, ".") > 0 Then
                            
                                'Different formatting for numbered and lettered lists
                                With para.Range.ParagraphFormat
                                    .SpaceBefore = 0
                                    .SpaceBeforeAuto = False
                                    .SpaceAfter = 0
                                    .SpaceAfterAuto = False
    

    Wednesday, July 29, 2015 2:38 PM
  •                             End With
                                
                            Else
                            
                                'Different formatting for bulleted lists
                                With para.Range.ParagraphFormat
                                    .SpaceBefore = 3
                                    .SpaceBeforeAuto = False
                                    .SpaceAfter = 3
                                    .SpaceAfterAuto = False
                                End With
                                                        
                            End If
                            
                            listLevel = para.Range.ListFormat.ListLevelNumber
                                 
                            'Detect and indent nested lists
                            para.Range.ParagraphFormat.LeftIndent = (listLevel - 1) * 15
                            para.Range.ListParagraphs(1).FirstLineIndent = 0
                            para.Range.ListParagraphs(1).TabStops(1).Position = 15
                            para.Range.ListParagraphs(1).TabStops(2).Position = 30
                            para.Range.ListParagraphs(1).TabStops(3).Position = 45
                            para.Range.ListParagraphs(1).TabStops(4).Position = 60
                            para.Range.ListParagraphs(1).TabHangingIndent (1)
                        
                        Else
                     
                            ' The paragraph is normal text
                            With para.Range.ParagraphFormat
                                .SpaceBefore = 0
                                .SpaceBeforeAuto = False
                                .SpaceAfter = 0
                                .SpaceAfterAuto = False
                            End With
                        
                        End If
                    
                    End If
                
                End If
            
            End If
            
            ' For most paragraphs, we want the standard verdana font, but there is some text that is usually
            ' associated with code snippets or report output that we do NOT want to be set to verdana
            '
            '  "Courier New" = code snippet font
            '  "Lucida Console" = the default report font from FCB
            '  "Consolas" = (newer) code snippet font - CMK 01May2015 - Added
            '
            If para.Range.Font.Name <> "Courier New" And para.Range.Font.Name <> "Lucida Console" And para.Range.Font.Name <> "Consolas" Then
                para.Range.Font.Name = "Verdana"
            End If
            
        Next
        
        Set para = Nothing
        
        Dim tbl As Table
    
        ' Loop through all tables, apply formatting
        For Each tbl In ActiveDocument.Tables
       
            ' Repeat header row
            tbl.Select
            tbl.Cell(1, 1).Select
            Selection.Rows.HeadingFormat = True
            
            ' Make it so the first row in a table is not the only row at the bottom of the page
            Selection.ParagraphFormat.KeepWithNext = True
            
            tbl.Select
                 
            ' Do not have a row break across the page
            tbl.Rows.AllowBreakAcrossPages = False
            
            ' Add cell padding
            tbl.TopPadding = InchesToPoints(0.03)
            tbl.BottomPadding = InchesToPoints(0.03)
            tbl.LeftPadding = InchesToPoints(0.03)
            tbl.RightPadding = InchesToPoints(0.03)
            
        Next
        
        Set tbl = Nothing
        
        ' We don't want any content between the WO header and the start of the Functional Design section
        Dim fromText As String, toText As String
        fromText = "\([0-9][0-9][0-9][0-9]\)"   'searches for "(####)"
        toText = "Functional Design  ("
        
        Selection.Find.ClearFormatting
        Selection.Find.Style = ActiveDocument.Styles("Heading 1")
        With Selection.Find
            .Text = fromText
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = True
        End With
        
        ' Only if the above is found, then continue
        If Selection.Find.Execute = True Then
                
            Selection.HomeKey Unit:=wdLine
            Selection.MoveDown Unit:=wdLine, Count:=1
            
            'Selection.Extend
            Selection.ExtendMode = True
             
            Selection.Find.ClearFormatting
            Selection.Find.Style = ActiveDocument.Styles("Heading 2")
            With Selection.Find
                .Text = toText
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindContinue
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = False
            End With
            
            ' Only if the above is found...
            If Selection.Find.Execute = True Then
            
                ' Move back (do not delete "Functional Design (")
                Selection.MoveLeft Unit:=wdCharacter, Count:=Len(toText), Extend:=wdExtend
                
                ' Delete all content between Heading 1 and the "Functional Design" heading 2, if there is somethign to delete
                If Selection.Characters.Count > 1 Then
                    Selection.Delete Unit:=wdCharacter, Count:=1
                End If
            
            End If
        
        End If
        Selection.ExtendMode = False
        Dim hlink As Hyperlink
        
        ' Loop through all hyperlinks in the document, and if it's not a web link or mailto link, embed the document the link points to just in front of the link
           For Each hlink In ActiveDocument.Hyperlinks
            If Left(LCase(hlink.Name), 4) <> "http" And Left(LCase(hlink.Name), 6) <> "mailto" Then
                hlink.Range.Select
                Selection.HomeKey Unit:=wdLine
                Selection.InlineShapes.AddOLEObject FileName:=ActiveDocument.Path & "/" & hlink.Name, LinkToFile:=False, DisplayAsIcon:=True, IconLabel:=Trim(hlink.TextToDisplay)
            End If
        Next
        
        ' Now loop through all hyperlinks again and remove the original ALM text version
        
        Dim i As Integer, hyperLinkCount As Integer
        i = 1       ' start at the first hyperlink (don't change this) - as you delete hyperlinks from the document what "Hyperlinks(1)" points to changes
        hyperLinkCount = ActiveDocument.Hyperlinks.Count
       
        ' While there are hyperlinks to process...
        While hyperLinkCount > 0
        
            ' If it's a web link or mailto link do nothing and move to the next link
            If Left(LCase(ActiveDocument.Hyperlinks(i).Name), 4) = "http" Or Left(LCase(ActiveDocument.Hyperlinks(i).Name), 6) = "mailto" Then
                i = i + 1
            Else
                ' If it's not a web link, select it and remove it
                ActiveDocument.Hyperlinks(i).Range.Select
                Selection.Delete
            End If
            
            ' We've processed a hyperlink, so decrement the count
            hyperLinkCount = hyperLinkCount - 1
        Wend
            
        ' When the Change Request is deep in the folder structure, it will apply Heading 9 to all headings past a certain point, which is translated
        ' by the macro to Heading 4. Using the unique ID naming scheme, loop through all the headings and apply the proper style.
        
        Selection.HomeKey Unit:=wdStory
       
        Selection.Find.ClearFormatting
        Selection.Find.Style = ActiveDocument.Styles("Heading 4")
        With Selection.Find
            .Text = "\(?@\)"    ' finds the artifact ID within the Heading 4 style (###.###.###.##)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = True
        End With
            
        Dim firstTime As Boolean, keepSearching As Boolean, firstHeadingText As String, newStyle As String
        keepSearching = True
        firstTime = True
        firstHeadingText = ""
        
        While keepSearching = True
        
            If Selection.Find.Execute = True Then
                
                ' Are we back at the first heading we found? If yes, exit.
                If firstHeadingText = Selection.Range.Text Then
                    keepSearching = False
                End If
                
                If firstTime = True Then
                    firstHeadingText = Selection.Range.Text
                    firstTime = False
                End If
                
                ' The number of periods in the unique ID determines the level
                Select Case UBound(Split(Selection.Range.Text, "."))
                
                    Case 0 To 2
                        newStyle = "Heading 4"
                    
                    Case 3
                        newStyle = "Heading 5"
                    
                    Case 4
                        newStyle = "Heading 6"
                    
                    Case 5
                        newStyle = "Heading 7"
                        
                    Case 6
                        newStyle = "Heading 8"
                        
                    Case 7
                        newStyle = "Heading 9"
                    
                    Case Else
                        newStyle = "Heading 4"
                
                End Select
                
                ' Select the whole heading
                Selection.Paragraphs(1).Range.Select
                
                ' Apply the proper style
                Selection.Range.Style = newStyle
                Selection.Range.ParagraphFormat.KeepWithNext = True
                
                ' Move once to the right so searching can continue
                Selection.MoveRight wdCharacter
                
            Else
                keepSearching = False
            End If
           
        Wend
        
        If Application.ActiveDocument.TablesOfContents.Count > 0 Then
            Application.ActiveDocument.TablesOfContents(1).Update
            Application.ActiveDocument.TablesOfContents(1).UpdatePageNumbers
        End If
        
        FinishTime = Timer
        TotalTime = FinishTime - StartTime
      
        ActiveWindow.View.Type = wdPrintView
            
        ' Place the cursor on the first page
        Selection.HomeKey Unit:=wdStory
        
        ' Turn off Spelling and Grammar Checking for the document (NO SQUIGGLES!)
        ActiveDocument.SpellingChecked = True
        ActiveDocument.Range.NoProofing = True
        Selection.Find.ClearFormatting
    
        ' Reset the "find" settings - if not done, when users do ctrl-F they will see wildcards turned on, search strings, etc.
        With Selection.Find
            .Text = ""
            .Forward = True
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        
        MsgBox "Done! Completed " & ActiveDocument.Paragraphs.Count & " paragraphs in " & Round(TotalTime, 0) & " seconds."
        
        Exit Sub
        
    ErrorHandler:
        
        Dim errorMessage As String
        
        Select Case Err.Number
        
            Case 5834
                errorMessage = "The macro attempted to apply a style that doesn't exist (" & "Heading " & (currentHeadingLevel - headingOffset) & "). " & _
                                "If a parent artifact has a unique ID all children under the parent must have a unique ID too. Please ensure the artifacts are ID'd correctly."
            Case Else
                errorMessage = "There was a problem formatting the document: " & Chr(13) & Chr(13) & Err.Number & ":" & Chr(13) & Err.Description
            
            End Select
            
            errorMessage = errorMessage & Chr(13) & Chr(13) & "Processing stopped."
        
        ActiveWindow.View.Type = wdPrintView
        
        MsgBox errorMessage
          
        Exit Sub
          
    End Sub
    Private Sub Macro_IMP()
    
      ' This sub is used to clean up formatting issues for FCB implementation documents coming out of HP ALM.
      '
      ' The macro has the following dependences:
      '   - It assumes the following templates are being used:
      '       - FCB Enhancement Document Template.docx
      '       - FCB Styles.docx
      '
      '
      
        On Error GoTo ErrorHandler
        
        Dim StartTime
        Dim EndTime
        Dim ElapsedTime
        
        StartTime = Timer
        
        Selection.WholeStory
            
        Selection.Range.SpellingChecked = True
        Selection.LanguageID = wdEnglishCanadian
        Selection.NoProofing = False
        Application.CheckLanguage = True
        
        
        Dim breakMarkerFound As Boolean
        breakMarkerFound = True
        
        Selection.HomeKey Unit:=wdStory
        
        ' Search for the section break placeholder in the template
        While breakMarkerFound = True
        
            Selection.Find.ClearFormatting
            With Selection.Find
                .Text = "<SectionBreak>" & Chr(13)
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
                   
           breakMarkerFound = Selection.Find.Execute
           
           ' For each one found, replace with an actual section break
           If breakMarkerFound = True Then
                Selection.Delete
    

    Wednesday, July 29, 2015 2:38 PM
  •             Selection.InsertBreak Type:=wdSectionBreakNextPage
            End If
            
        Wend
    
        Set myRange = Selection.Range
        ActiveDocument.TablesOfContents.Add Range:=myRange, _
        UseFields:=False, UseHeadingStyles:=True, _
        LowerHeadingLevel:=3, _
        UpperHeadingLevel:=1
      
        
        ' Remove weird circles followed by two paragraphs (junk added by ALM), do it twice just to make sure we catch everything
        For Count = 1 To 2
            
            Selection.WholeStory
            
            With Selection.Range.Find
                .Text = Chr(160) & Chr(160) & Chr(13) & Chr(13) ' weird space x 2 + paragraph
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
                .Execute Replace:=wdReplaceAll
            End With
            
        Next
        
        Selection.WholeStory
        
        Selection.Range.Font.Name = "Verdana"
        
        ' Remove extra carriage return that was marked with a special string in the template ("$.$(space)")
        With Selection.Range.Find
            .Text = "$.$ " & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
    
        Selection.WholeStory
    
        ' Remove extra carriage return that was marked with a special string in the template ("$.$")
        With Selection.Range.Find
            .Text = "$.$" & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Remove Unique Id text for clear .PostImp, .PreImp, .SysDB..etc
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".PostImp"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".PreImp"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".SysDB"
            .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
        
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".ECSChanges"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".Policy"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".CleanUp"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".ExtTest"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".MemImpact"
            .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
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ".OutScope"
            .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
        
        'Remove all empty artifacts with only N/A
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(13) & "N/A" & Chr(13) & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(11) & Chr(13) & "N/A" & Chr(13) & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(13) & "N/A" & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(13) & "System Impact:" & Chr(13) & Chr(13) & "N/A" & Chr(13) & Chr(13) & "Production DB Structure Changes:" & Chr(13) & Chr(13) & "N/A" & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(13) & "System Impact:" & Chr(13) & "N/A" & Chr(13) & Chr(13) & "Production DB Structure Changes:" & Chr(13) & "N/A" & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "[0-9]{4}" & Chr(13) & "System Impact:" & Chr(13) & Chr(13) & "Production DB Structure Changes:" & Chr(13) & Chr(13) & "N/A" & Chr(13) & Chr(13)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        
        Dim para As Paragraph
        Dim lastPara As Paragraph
        Dim paraStyle As Style
        Dim currentHeadingLevel As Integer
        Dim headingOffset As Integer
        Dim listLevel As Integer
        Dim listStringValue As String
        
        Dim justEntered As Boolean   ' flag to keep track of when we just enter a table or are on an image
        justEntered = True
                
        ' Loop through each paragraph and process it
        For Each para In ActiveDocument.Paragraphs
        
            para.Range.Select
           
            ' If we're in a table or on an image, fomat the paragraph directly above it to Keep with Next (additional table processing is done later in the macro)
            If para.Range.Information(wdWithInTable) = True Or para.Range.InlineShapes.Count > 0 Then
                
                If justEntered = True Then
                    justEntered = False
                    
                    ' If we're not just on an empty paragraph, format it
                    If lastPara.Range.Text <> Chr(13) Then
                        lastPara.KeepWithNext = True
                        lastPara.SpaceAfter = 6
                    End If
                    
                End If
                ' Are we in a list?
                If para.Range.ListParagraphs.Count > 0 Then
                    
                    listStringValue = para.Range.ListFormat.ListString
                            
                    ' Lists that are numbers or letters have a "." in them (i.e. "1." or "a.")
                    If InStr(listStringValue, ".") > 0 Then
                            
                        'Different formatting for numbered and lettered lists
                        With para.Range.ParagraphFormat
                            .SpaceBefore = 0
                            .SpaceBeforeAuto = False
                            .SpaceAfter = 0
                            .SpaceAfterAuto = False
                        End With
                                
                    Else
                            
    
                        'Different formatting for bulleted lists
                        With para.Range.ParagraphFormat
                            .SpaceBefore = 3
                            .SpaceBeforeAuto = False
                            .SpaceAfter = 3
                            .SpaceAfterAuto = False
                        End With
                        
                    End If
                            
                    listLevel = para.Range.ListFormat.ListLevelNumber
                    
                    'Detect and indent nested lists
                    para.Range.ParagraphFormat.LeftIndent = (listLevel - 1) * 15
                    para.Range.ListParagraphs(1).FirstLineIndent = 0
                    para.Range.ListParagraphs(1).TabStops(1).Position = 15
                    para.Range.ListParagraphs(1).TabStops(2).Position = 30
                    para.Range.ListParagraphs(1).TabStops(3).Position = 45
                    para.Range.ListParagraphs(1).TabStops(4).Position = 60
                    para.Range.ListParagraphs(1).TabHangingIndent (1)
                        
                Else
                     
                    ' The paragraph is normal text
                    With para.Range.ParagraphFormat
                        .SpaceBefore = 0
                        .SpaceBeforeAuto = False
                        .SpaceAfter = 0
                        .SpaceAfterAuto = False
                    End With
                        
                End If
            
            Else
            
               justEntered = True     ' reset the table flag
                Set lastPara = para
                Set paraStyle = para.Range.Style
                
                Dim paraStyleName As String
                paraStyleName = ""
                If Not paraStyle Is Nothing Then paraStyleName = CStr(paraStyle)
                        
                ' If the paragraph is a heading....
                If InStr(paraStyleName, "Heading") > 0 And IsNumeric(Mid(paraStyleName, 9)) Then
               
                    ' If it's a heading without an ID, remove it
                    If InStr(para.Range.Text, "()") > 0 Then
                        headingOffset = Mid(paraStyleName, 9)
                        para.Range.Delete
                    Else
        
                        ' Adjust the heading
                        currentHeadingLevel = Mid(paraStyleName, 9)
                        para.Range.Style = "Heading " & (currentHeadingLevel - headingOffset)
                        para.Range.ParagraphFormat.KeepWithNext = True
    
                        
                        ' Add a page break to the beginning if it's Heading 1 or the beginning of Technical Design section
                        If para.Style = "Heading 1" Or InStr(para.Range, "Technical Design") Then
                            Selection.HomeKey Unit:=wdLine
                            Selection.InsertBreak Type:=wdPageBreak
                        End If
                        
                    End If
            
                Else
            
                    ' if the paragraph is an empty paragraph added by ALM, remove it
                    If para.Range.Text = Chr(13) And para.Range.ParagraphFormat.SpaceAfterAuto = -1 Then
                        para.Range.Delete
                    
                    Else
                    
                        ' Are we in a list?
                        If para.Range.ListParagraphs.Count > 0 Then
                        
                            listStringValue = para.Range.ListFormat.ListString
                            
                            ' Lists that are numbers or letters have a "." in them (i.e. "1." or "a.")
                            If InStr(listStringValue, ".") > 0 Then
                            
                                'Different formatting for numbered and lettered lists
                                With para.Range.ParagraphFormat
                                    .SpaceBefore = 0
                                    .SpaceBeforeAuto = False
                                    .SpaceAfter = 0
                                    .SpaceAfterAuto = False
                                End With
                                
                            Else
                            
                                'Different formatting for bulleted lists
                                With para.Range.ParagraphFormat
                                    .SpaceBefore = 3
                                    .SpaceBeforeAuto = False
                                    .SpaceAfter = 3
                                    .SpaceAfterAuto = False
                                End With
                                                        
                            End If
                            
                            listLevel = para.Range.ListFormat.ListLevelNumber
                                 
                            'Detect and indent nested lists
                            para.Range.ParagraphFormat.LeftIndent = (listLevel - 1) * 15
                            para.Range.ListParagraphs(1).FirstLineIndent = 0
                            para.Range.ListParagraphs(1).TabStops(1).Position = 15
                            para.Range.ListParagraphs(1).TabStops(2).Position = 30
                            para.Range.ListParagraphs(1).TabStops(3).Position = 45
                            para.Range.ListParagraphs(1).TabStops(4).Position = 60
                            para.Range.ListParagraphs(1).TabHangingIndent (1)
                        
                        Else
                     
                            ' The paragraph is normal text
                            With para.Range.ParagraphFormat
                                .SpaceBefore = 0
                                .SpaceBeforeAuto = False
                                .SpaceAfter = 0
                                .SpaceAfterAuto = False
                            End With
                        
                        End If
                    
                    End If
                
                End If
            
            End If
            
        Next
           
        Dim tbl As Table
    
        ' Loop through all tables, apply formatting
        For Each tbl In ActiveDocument.Tables
       
            ' Repeat header row
            tbl.Select
            tbl.Cell(1, 1).Select
            Selection.Rows.HeadingFormat = True
            
            ' Make it so the first row in a table is not the only row at the bottom of the page
            Selection.ParagraphFormat.KeepWithNext = True
            
            tbl.Select
                 
            ' Do not have a row break across the page
            tbl.Rows.AllowBreakAcrossPages = False
            
            'sma added to resize tabel just for implementation doc
            tbl.PreferredWidthType = wdPreferredWidthAuto
            
            
            ' Add cell padding
            tbl.TopPadding = InchesToPoints(0.03)
            tbl.BottomPadding = InchesToPoints(0.03)
            tbl.LeftPadding = InchesToPoints(0.03)
            tbl.RightPadding = InchesToPoints(0.03)
            
            ' Adjust paragraph spacing within the table
            tbl.Range.ParagraphFormat.SpaceBefore = 0
            tbl.Range.ParagraphFormat.SpaceAfter = 0
            tbl.Style.NoSpaceBetweenParagraphsOfSameStyle = True
            
        Next
        
        
     
      'Reformat the page footer with the nunmber of pages remaining
        ActiveDocument.Sections(ActiveDocument.Sections.Count) _
            .Footers(wdHeaderFooterPrimary).Range.Select
        With Selection
            .Paragraphs(1).Alignment = wdAlignParagraphCenter
            .TypeText Text:="Page "
            .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "PAGE ", PreserveFormatting:=True
            .TypeText Text:=" of "
            .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "SECTIONPAGES ", PreserveFormatting:=True
        End With
        
        If ActiveWindow.View.SplitSpecial = wdPaneNone Then
            ActiveWindow.ActivePane.View.Type = wdPrintView
        Else
            ActiveWindow.View.Type = wdPrintView
        End If
        
    
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
        
        'Different Header and Footer content of the Title Page
        With ActiveDocument.Sections(1)
            .PageSetup.DifferentFirstPageHeaderFooter = True
        End With
    
        
        If Application.ActiveDocument.TablesOfContents.Count > 0 Then
            Application.ActiveDocument.TablesOfContents(1).Update
            Application.ActiveDocument.TablesOfContents(1).UpdatePageNumbers
        End If
        
        FinishTime = Timer
        TotalTime = FinishTime - StartTime
        
        ' Place the cursor on the first page
        Selection.HomeKey Unit:=wdStory
        
        MsgBox "Done! Completed " & ActiveDocument.Paragraphs.Count & " paragraphs in " & Round(TotalTime, 0) & " seconds."
        Exit Sub
        
    ErrorHandler:
        
        Dim errorMessage As String
        
        Select Case Err.Number
        
            Case 5834
                errorMessage = "The macro attempted to apply a style that doesn't exist (" & "Heading " & (currentHeadingLevel - headingOffset) & "). " & _
                                "If a parent artifact has a unique ID all children under the parent must have a unique ID too. Please ensure the artifacts are ID'd correctly."
            Case Else
                errorMessage = "There was a problem formatting the document: " & Chr(13) & Chr(13) & Err.Number & ":" & Chr(13) & Err.Description
            
            End Select
            
            errorMessage = errorMessage & Chr(13) & Chr(13) & "Processing stopped."
            
        MsgBox errorMessage
          
        Exit Sub
          
    End Sub
    

    Wednesday, July 29, 2015 2:39 PM
  • The code that does the resizing is in the second reply with code in the Macro_FCB function.  This is the current production version without all the other things I have been trying.  Many thanks for anyone who takes the time to look at all this.
    Wednesday, July 29, 2015 2:43 PM
  • Posting 1700+ lines of mostly irrelevant code doesn't really help solve the problem when the issue concerns only 4 lines of the total:

    For Each Pic In ActiveDocument.InlineShapes
      Pic.ScaleHeight = 100
      Pic.ScaleWidth = 100
    Next

    There is nothing about that code that would explain any inline shapes not resizing though, as I said before, any that have a locked aspect ratio that is not proportional to their original aspect ratio cannot be correctly re-scaled by this code - you would have to unlock the aspect ratio beforehand. And, since your code only deals with inlineshapes in the main story, inlineshapes in other story ranges and shape objects in all story ranges won't be processed.

    I also note that, after the above code, you have:

    Selection.InlineShapes.AddOLEObject FileName:=ActiveDocument.Path & "/" & hlink.Name, LinkToFile:=False, DisplayAsIcon:=True, IconLabel:=Trim(hlink.TextToDisplay)

    Obviously, your re-scaling won't apply to those either, since they're added after that process has finished.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Wednesday, July 29, 2015 10:18 PM
  • Thanks for your reply.  I know that the majority of the code has nothing to do with the image resizing, it was a hail mary that someone may see something else that was could be causing a problem.  You say that the code won't work on images with a locked aspect ratio but my problem is that this does work on 100% of the images sometimes and running it a second time on an identical document or on a different computer and it won't resize any of them, or resizes the first half of them and stops.  I have also tried having it unlock the aspect ratio before the change with no difference in results.  But I guess there is just no solution for this problem, at least not one that can be resolved through the code.
    Wednesday, July 29, 2015 10:28 PM
  • HI Ben,

    FWIW, you can't just apply a 100% scale to an image in a document and always get a satisfactory result. More times than not an image that already exists in a document has already been scaled to fit within the borders of the page, a table cell, etc. With that said of course, if your images are tiny thumbnails that fit within a containers borders, then my comment here does not apply.

    Since there isn't a picture object property, to my knowledge, that maintains the object's original dimensions you have to make some assumptions about the images that are contained within your document and/or maintain a record of original scale size so that you know what is the relative "100%" size for the picture's container. So for example, if I have a 10" wide picture and it must fit into a 5" wide picture container, then this picture's 100% scale size (meaning it fills 100% of the container) is an actual 50% of the picture's original width.

    I'm wondering if this fact about scaling within picture containers (page borders, table cells, text boxes, etc) is having some factor in what is appearing to you to be a failure of Word 2010 to "scale" consistently.


    Kind Regards, Rich ... http://greatcirclelearning.com

    Monday, August 3, 2015 11:24 AM