VBA Module for inserting images into Photo Album

Jjansens · #1 10-06-2022, 08:23 AM

Hello,

Currently looking for a module that will do the following:

- Loading photo's in a document
- If a photo was taken horizontally (Width > Hight) it need to be rotated 270 degrees
- The photo's need to be resized to 12 cm hight and 8 cm width
- The rotated Photo's need to be resized to 12 cm Width en 8 cm Hight (so all photo's in the document are the same)
- A Row under the photo's that contain the photo number
- Compress all the uploaded photo's to 200 dpi

I added an File of the end result. The code sometimes does need to process a couple hunderd photo's.

In the attached File picture 2 has been rotated and set the correct measurments as stated above.

Let me know if this all is possible! Glad to return a favor/payment for those who help me

macropod · #2 10-06-2022, 01:53 PM

Did you look at: https://www.msofficeforums.com/drawi...ument-all.html. It already does most of what you ask for.

Jjansens · #3 10-07-2022, 01:13 AM

Quote:

Originally Posted by macropod

Did you look at: https://www.msofficeforums.com/drawi...ument-all.html. It already does most of what you ask for.

Thanks for the reply! i did check that, but the code doesn't rotate the inserted pictures. Tried rewriting the code but that did not go well.

macropod · #4 10-07-2022, 02:29 PM

Try adding:

Code:

Aspect as Boolean

to:

Code:

Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape

inserting:

Code:

Aspect = RwHght > ColWdth

before:

Code:

On Error GoTo 0

and changing:

Code:

        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With

Code:

        With iShp
          .LockAspectRatio = True
          If (.Height > .Width) <> Aspect Then
            Set Shp = .ConvertToShape
            Shp.Rotation = 90
            Shp.ConvertToInlineShape
          End If
        End With
        Set iShp = oTbl.Cell(r, c).Range.InlineShapes(1)
        With iShp
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With

abosman · #5 11-16-2022, 08:02 AM

Thanks Paul for the great advice.
I have used the suggestions in this thread and your code to insert images and rotate them correctly.
However, one odd behaviour that I did notice was that from the second page onward, the first row would not rotate the image correct, even if its width exceeded its height. When controlling if that image was sucessfully steered through that particular If condition, it was reported. So I am sure that these images are not skipped but the rotation seems to fail. Do you have any suggestions why this could be the case?

Code:

Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape, Aspect As Boolean
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit


'NumCols = CLng(InputBox("How Many Columns per Row?"))
NumCols = 2
ColWdth = PointsToCentimeters(TblWdth / NumCols)
'ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
ColWdth = CentimetersToPoints(CSng(8))
'RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 5)?")))
RwHght = CentimetersToPoints(CSng(11))
Aspect = RwHght > ColWdth
On Error GoTo 0
'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
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
    End With
    CaptionLabels.Add Name:="Foto"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      'Format the rows
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If (.Height > .Width) <> Aspect Then
            Set shp = .ConvertToShape
            shp.Rotation = 270
            shp.ConvertToInlineShape
          End If
        End With
        Set iShp = oTbl.Cell(r, c).Range.InlineShapes(1)
        With iShp
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
          iShp.Width = CentimetersToPoints(10.5)
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = ": " & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Foto", Title:=StrTxt, _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
          .Paragraphs.Alignment = wdAlignParagraphCenter
          .Characters.First = vbNullString
          .Characters.Last.Previous = vbNullString
        End With
        'Exit when we're done
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
  Else
  End If
End With

ErrExit:
Application.ScreenUpdating = True
End Sub

macropod · #6 11-18-2022, 03:43 PM

Since the images are rotated on a case-by-case basis as they are inserted, I can see no reason for the table's page count to have any bearing on the matter.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Cannot group picture after having used photo album	mabi2911	PowerPoint	2	03-06-2017 11:50 PM
Photo Album to Include Videos	Rob-161	PowerPoint	1	09-27-2016 11:27 AM
Photo album with each slide for 2.5 seconds (not 2 and not 3)	GregVolk	PowerPoint	3	05-31-2016 11:25 AM
power point 2011 is there anyway to create a photo albumn(s) and insert the album bet	Jrmatm26538	PowerPoint	6	02-14-2012 09:00 AM
Help!!Need to apply same custom animation to all slides in a photo album.	watsonstudios	PowerPoint	3	05-27-2011 01:36 PM