Word Macro: Set page orientation after section break

Question

This question is about a new problem that came up while I was trying to get an addition to something to work I already asked a question about.

What I want my macro to do/what it's already kind of doing:

• Add a header to a Word document (same one for the whole document)
• Read image files from a specific folder from the HDD and insert them into the document
• Add a section break if the image orientation (landscape or portrait) differs from the previous one and set the page orientation for the new section accordingly (BEFORE adding the image)
• Add a line break and the file name of the image
• Add a page break (each image gets its own page, no matter its size)

To ensure that the name doesn't get pushed to the next page (if the image fills the whole page), I set the bottom margin to a higher value before adding the image and the name and then set the margin back to the original value. This way the image is a little bit smaller and leaves enough space for the name.

My code (see below) does add section breaks but it seems like it sets the orientation for the whole document, not just the current section, so I end up with the same orientation on all pages. The images are also only added in the very last section without any page/section breaks in between.

How do I fix this?

In the other question someone already posted full code to set the orientation but I'd prefer understanding why my code doesn't work as intended to just copying someone else's completely different one.

My code:

Sub ImportImages(path As String)
    Dim fs As Object
    Dim ff As Variant
    Dim img As Variant
    Dim i As Long
    Dim fsize As Long
    Dim bottomMarginOriginal As Single
    Dim topMarginOriginal As Single
    Dim vertical As Boolean

    Dim objShell As New Shell
    Dim objFolder As Folder
    Dim objFile As ShellFolderItem

    Dim width As Integer
    Dim height As Integer

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ff = fs.GetFolder(path).Files
    i = 0
    fsize = ff.Count
    vertical = True
    Set objFolder = objShell.NameSpace(path)

    With ActiveDocument
        bottomMarginOriginal = .PageSetup.BottomMargin
        topMarginOriginal = .PageSetup.TopMargin

        For Each img In ff
            Select Case Right(img.name, 4)
                Case ".bmp", ".jpg", ".gif", ".png", "tiff", ".tif"
                    Set objFile = objFolder.ParseName(img.name)
                    width = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
                    height = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")

                    If width > height Then
                        If vertical = False Then 'Already landscape -> just add page break
                            .Characters.Last.InsertBefore Chr(12)
                        Else 'Set to landscape
                            Selection.InsertBreak Type:=wdSectionBreakNextPage
                            .PageSetup.Orientation = wdOrientLandscape
                            .PageSetup.TopMargin = topMarginOriginal 'Adjust margins to new orientation
                            .PageSetup.RightMargin = bottomMarginOriginal
                            .PageSetup.BottomMargin = bottomMarginOriginal
                            .PageSetup.LeftMargin = bottomMarginOriginal
                            .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test " & i 'Set header
                            vertical = False
                        End If
                    ElseIf height > width Then
                        If vertical = True Then 'Already portrait -> just add page break on page 2+
                            If i <> 0 Then
                                .Characters.Last.InsertBefore Chr(12)
                            End If
                        Else 'Set to portrait
                            Selection.InsertBreak Type:=wdSectionBreakNextPage
                            .PageSetup.Orientation = wdOrientPortrait
                            .PageSetup.TopMargin = topMarginOriginal 'Adjust margins to new orientation
                            .PageSetup.RightMargin = bottomMarginOriginal
                            .PageSetup.BottomMargin = bottomMarginOriginal
                            .PageSetup.LeftMargin = bottomMarginOriginal
                            .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test " & i 'Set header
                            vertical = True
                        End If
                    Else
                        If i <> 0 Then
                            .Characters.Last.InsertBefore Chr(12) 
                        End If
                    End If

                    .PageSetup.BottomMargin = bottomMarginOriginal + Application.CentimetersToPoints(1) 'Add 1cm to the bottom margin
                    i = i + 1
                    .Characters.Last.InlineShapes.AddPicture filename:=img
                    .Characters.Last.InsertBefore Chr(11) & img.name
                    .PageSetup.BottomMargin = bottomMarginOriginal 'Reset bottom margin to default
            End Select
        Next
    End With
End Sub

Answer 1

Here is the concept code based around putting images in Tables. A habit I have acquired from long long use of Word.

At the moment the ParseName keyword isn't being recognised even though I added a reference to Microsoft Shell etc etc.

Not a pagebreak in sight as they are not needed.

Option Explicit

Const PortraitPictureHeight                 As Long = 0 ' change to cm value
Const PortraitTextHeight                    As Long = 0 ' change to a cm value
Const LandscapePictureHeight                As Long = 0 ' change to a cm value
Const LandscapeTextHeight                   As Long = 0 ' change to a cm value
Const HeightOfLineAfterTable                 As Long = 0 ' change to a points


Sub test()

ImportImages "C:\\Users\\slayc\\Pictures"

End Sub
Sub ImportImages(path As String)

    Dim fs                      As Scripting.FileSystemObject
    Dim ff                      As Variant
    Dim img                     As Variant

    Dim objShell                As Shell
    Dim objFolder               As Folder
    Dim objFile                 As ShellFolderItem

    Dim width                   As Long
    Dim height                  As Long


    Set fs = New Scripting.FileSystemObject
    Set ff = fs.GetFolder(path).Files

    Set objShell = New Shell
    Set objFolder = objShell.NameSpace(path)

    ' The assumption is that we are adding sections to the end of the document
    ' so we add the Heder to the last document
    ' this header will be copied to each section we add to the document
    ' when we use Activedocument.sections.add
    ActiveDocument.Sections.Last.Headers(wdHeaderFooterPrimary).Range.Text = "This is your header"

    For Each img In ff

        If InStr(".bmp,.jpg,.gif,.png,.tiff", Right(img.Name, 4)) = 0 Then GoTo Continue_img
        Set objFile = objFolder.ParseName(img.Name)
        width = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
        height = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")

        ' every image gets its own section with its own orientation
        If width > height Then

            InsertLandscapeSection

        Else

            InsertPortraitSection

        End If

        FormatLastTable

        With ActiveDocument.Sections.Last.Range.Tables(1).Range

.Rows(1).Range.Cells(1).Range.Characters.Last.InlineShapes.AddPicture FileName:=img
                .Rows(2).Range.Cells(1).Range.Text = img.Name

        End With

Continue_img:
    Next

End Sub

Public Sub InsertLandscapeSection()

Dim my_range                    As Word.Range

    With ActiveDocument.Sections

        ' Deal with the case where the first section is the last section
        If .Last.Range.Tables.Count > 0 Then

            .Add
            .Last.Range.Previous(unit:=wdParagraph).Font.Size = HeightOfLineAfterTable

        End If

        .Last.PageSetup.Orientation = wdOrientLandscape

        With .Last

            Set my_range = .Range.Duplicate
            my_range.Collapse direction:=wdCollapseStart
            .Range.Tables.Add my_range, 2, 1

            With .Range.Tables(1).Range

                .Rows.HeightRule = wdRowHeightExactly
                .Rows(1).height = CentimetersToPoints(LandscapePictureHeight)
                .Rows(2).height = CentimetersToPoints(LandscapeTextHeight)

            End With

        End With

    End With

End Sub

Public Sub InsertPortraitSection()

Dim my_range                    As Word.Range

    With ActiveDocument.Sections

        If .Last.Range.Tables.Count > 0 Then

            .Add
            .Last.Range.Previous(unit:=wdParagraph).Font.Size = HeightOfLineAfterTable

        End If

        .Last.PageSetup.Orientation = wdOrientPortrait

        With .Last

            Set my_range = .Range.Duplicate
            my_range.Collapse direction:=wdCollapseStart
            .Range.Tables.Add my_range, 2, 1

            With .Range.Tables(1).Range

                .Rows.HeightRule = wdRowHeightExactly
                .Rows(1).height = CentimetersToPoints(PortraitPictureHeight)
                .Rows(2).height = CentimetersToPoints(LandscapeTextHeight)

            End With

        End With

    End With

End Sub

Sub FormatLastTable()

    With ActiveDocument.Sections.Last.Range.Tables(1)

        ' turn off all borders
        .Borders.Enable = False

        'Do any additional formatting of the table that is not related to row height

    End With


End Sub