Word Macro: Change page orientation depending on image ratio - vba

Question

My macro currently does the following:
It adds a header to a Word document, then reads image files from a specific folder from the HDD and adds them to the same document with the name of the file below the image and a page break after each image. 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.
What I now want to add to this:
Switch the orientation of the page depending on the images' width and height and add a manual page break, so I can have multiple orientations in the same document.
But I'm already failing at the first thing:
How do I get the width/height/ration of the images before adding them
to the document (Img.Width doesn't seem to exist in Word)? I don't care what kind of information it is, as long as it tells me if the image is landscape or portrait.
How do I add a manual page break (Chr(12) just jumps to the next page without adding an actual break)?
Adding a manual page break also means that my header text won't be used afterwards but how do I set it for the new "Section"? I'm guessing it's not still ActiveDocument.Sections(1) then, is it?
My code (just the image import Sub):
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 vertical As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
Set ff = fs.GetFolder(path).Files
i = 0
fsize = ff.Count
vertical = True
With ActiveDocument
bottomMarginOriginal = .PageSetup.BottomMargin
.PageSetup.BottomMargin = bottomMarginOriginal + Application.CentimetersToPoints(1) 'Add 1cm to margin
For Each Img In ff
Select Case Right(Img.name, 4)
Case ".bmp", ".jpg", ".gif", ".png", "tiff", ".tif"
If i <> 0 Then
.Characters.Last.InsertBefore Chr(12) 'Add page break before adding the img
Debug.Print "Width: " & Img.Width 'Error message: Doesn't exist!
Else
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test text"
.PageSetup.Orientation = wdOrientLandscape 'TODO: Check the img ratio
vertical = False
End If
i = i + 1
.Characters.Last.InlineShapes.AddPicture filename:=Img 'Add the img
.Characters.Last.InsertBefore Chr(11) & Img.name 'Add a line break and the img name
End Select
Next
End With
ActiveDocument.PageSetup.BottomMargin = bottomMarginOriginal
End Sub
Edit:
This code 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, plus the images are only added in the very last section without any page/section breaks in between. How do I fix this?
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

You don't need to get the image dimensions beforehand. Try something along the lines of:
Sub AddPics()
Application.ScreenUpdating = False
Dim i As Long, StrTxt As String, Rng As Range, vCol
Dim sAspect As Single, sLndWdth As Single, sLndHght As Single
Dim sMgnL As Single, sMgnR As Single, sMgnT As Single, sMgnB As Single, sMgnG As Single
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
Set vCol = .SelectedItems
Else
Exit Sub
End If
End With
With ActiveDocument
'Create a paragraph Style with 0 space before/after & centre-aligned
On Error Resume Next
.Styles.Add Name:="Pic", Type:=wdStyleTypeParagraph
With .Styles("Pic").ParagraphFormat
.Alignment = wdAlignParagraphCenter
.SpaceAfter = 0
.SpaceBefore = 0
End With
On Error GoTo 0
With .PageSetup
sMgnL = .LeftMargin: sMgnR = .RightMargin: sMgnT = .TopMargin: sMgnB = .BottomMargin: sMgnG = .Gutter
End With
Set Rng = Selection.Range
With Rng
.Paragraphs.Last.Style = "Pic"
For i = 1 To vCol.Count
.InsertAfter vbCr
.Characters.Last.InsertBreak Type:=wdSectionBreakNextPage
.InlineShapes.AddPicture FileName:=vCol(i), LinkToFile:=False, SaveWithDocument:=True, Range:=.Characters.Last
'Get the Image name for the Caption
StrTxt = Split(Split(vCol(i), "\")(UBound(Split(vCol(i), "\"))), ".")(0)
'Insert the Caption below the picture
.Characters.Last.InsertBefore Chr(11) & StrTxt
Next
.Characters.First.Text = vbNullString
.Characters.Last.Previous.Text = vbNullString
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
'Reorient pages for landscape pics
If .Height / .Width < 1 Then
With .Range.Sections(1).PageSetup
.Orientation = wdOrientLandscape
.LeftMargin = sMgnL: .RightMargin = sMgnR: .TopMargin = sMgnT: .BottomMargin = sMgnB: .Gutter = sMgnG
sLndWdth = .PageWidth - sMgnL - sMgnR - sMgnG
sLndHght = .PageHeight - sMgnT - sMgnB
End With
.LockAspectRatio = True
.ScaleHeight = 100
If .Height > sLndHght Then .Height = sLndHght
If .Width > sLndWdth Then .Width = sLndWdth
End If
End With
Next
End With
End With
Application.ScreenUpdating = True
End Sub