Resize every 1st picture in a photo report page

[Tahmz]

Hi, this is a build up from a previous post by myself. I am unable to post the link to that because low post count.
Anyways..

Previously we worked on inserting 3 pictures from 3 different folders into a 3 different tables per word page. What i am trying to achieve now is resizing the photos. It will look something like this

Picture 1

Picture 2

Picture 3

Dimensions for Picture 1: .Height = InchesToPoints(1.0984), .Width = InchesToPoints(10.7322)

Dimensions for Picture 2 and 3: .Height = InchesToPoints(5.3833), .Width = InchesToPoints(6.72)

Previous code with the help of Macropod (thanks Paul), with some minor adjustments by me
This is the full code which adds the pictures from different folders. i only edited the .height and added a .width

Sub AddPicsFromFolders() 
    Application.ScreenUpdating = False 
    Dim ArrFldr(), ArrHght(), oTbl As Table, i As Long, j As Long 
    Dim strFolder As String, strFile As String 
    ArrFldr() = Array("Folder1", "Folder2", "Folder3") 
    ArrHght() = Array(2, 3, 3) 
    CaptionLabels.Add Name:="Picture" 
    For i = 0 To UBound(ArrFldr()) 
        strFolder = "C:\Users\" & Environ("Username") & "\Pictures\" & ArrFldr(i) & "\" 
        strFile = Dir(strFolder & "*.jpg", vbNormal) 
        j = 0 
        While strFile <> "" 
            j = j + 1 
            Set oTbl = ActiveDocument.Tables(j * (UBound(ArrFldr()) + 1) - UBound(ArrFldr()) + i) 
            With oTbl 
                .AllowAutoFit = False 
                 'Format the rows
                Call FormatRows(oTbl, CSng(ArrHght(i))) 
                 'Insert & size the Picture
                .Range.InlineShapes.AddPicture FileName:=strFolder & strFile, LinkToFile:=False, _ 
                SaveWithDocument:=True, Range:=.Cell(1, 1).Range 
                With .Range.InlineShapes(1) 
                    .LockAspectRatio = True 
                   
                    .Width = InchesToPoints(6.72)
                    .Height = InchesToPoints(5.33858)
                End With 
                 
                  'Insert the Caption on the row below the picture
                With .Cell(.Rows.Count, 1).Range 
                    .InsertBefore vbCr 
                    .Characters.First.InsertCaption Label:="Picture", _ 
                    Title:=Split(strFile, ".")(0), _ 
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False 
                    .Characters.First = vbNullString 
                    .Characters.Last.Previous = vbNullString 
                End With 
            End With 
            If j Mod 10 = 0 Then DoEvents 
            strFile = Dir() 
        Wend 
    Next 
    Application.ScreenUpdating = True 
End Sub 
 '
Sub FormatRows(oTbl As Table, Hght As Single) 
    With oTbl 
        With .Rows(1) 
            .Height = InchesToPoints(Hght) 
            .HeightRule = wdRowHeightExactly 
            .Range.Style = "Normal" 
        End With 
        With .Rows(2) 
            .Height = InchesToPoints(0.25) 
            .HeightRule = wdRowHeightExactly 
            .Range.Style = "Caption" 
        End With 
    End With 
End Sub

As you can guess, picture 1 dimensions will change to picture 2 and 3 dimensions as well. To solve this, i use:

Sub ResizePicture1()


Dim shp As Word.Shape
Dim ishp As Word.InlineShape
If Word.Selection.Type <> wdSelectionInlineShape And _
Word.Selection.Type <> wdSelectionShape Then
Exit Sub
End If
If Word.Selection.Type = wdSelectionInlineShape Then
Set ishp = Word.Selection.Range.InlineShapes(1)
ishp.LockAspectRatio = False
ishp.Height = InchesToPoints(1.0984)
ishp.Width = InchesToPoints(10.7322)
Else
If Word.Selection.Type = wdSelectionShape Then
Set shp = Word.Selection.ShapeRange(1)
shp.LockAspectRatio = False
shp.Height = InchesToPoints(1.0984)
shp.Width = InchesToPoints(10.7322)
End If
End If


End Sub

But i have to do this selecting every picture 1 of every page individually and then launching the above macro using a hotkey. (i.e its a 100 pages report).

So the options i think are
1. resize the picture 1 as it is added in (editing the 1st macro)
2. Creating a separate macro to resize just the 1st picture of every page. (tried using the macro recorder, doesnt work)

Any help with either options or an alternative option would be of great help. Many thanks for reading this long post.

cheers

[macropod]

If you had given each of the tables its own fixed height and width, there would be no need to so anything regarding the picture sizes (unless, for some reason their height and width were both smaller than the table height and width, respectively).

Regardless, you'll note that the code I posted (http://www.vbaexpress.com/forum/show...l=1#post359619) referenced the array
ArrHght() = Array(2, 3, 3)
to set the picture heights, using:
.Height = InchesToPoints(CSng(ArrHght(i)))
Your code modifications removed that flexibility and instead enforced a fixed height (presumably, your attempt at a fixed width fails, courtesy of '.LockAspectRatio = True') for all images. When using '.LockAspectRatio = True' you need only set the height or width - whichever you set last takes priority. In other words, the problem is of your own making.

[Tahmz]

Hi Paul
Sorry for gettting back so late. But i will try your suggestion. Thanks again