Word Macro: Set page orientation after section break - vba

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