Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 10-06-2022, 08:23 AM
Jjansens Jjansens is offline VBA Module for inserting images into Photo Album Windows 11 VBA Module for inserting images into Photo Album Office 2021
Novice
VBA Module for inserting images into Photo Album
 
Join Date: Oct 2022
Posts: 2
Jjansens is on a distinguished road
Arrow VBA Module for inserting images into Photo Album

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
Attached Images
File Type: jpg Photo collage as intended.jpg (34.3 KB, 23 views)
Reply With Quote
  #2  
Old 10-06-2022, 01:53 PM
macropod's Avatar
macropod macropod is offline VBA Module for inserting images into Photo Album Windows 10 VBA Module for inserting images into Photo Album Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,856
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Did you look at: https://www.msofficeforums.com/drawi...ument-all.html. It already does most of what you ask for.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 10-07-2022, 01:13 AM
Jjansens Jjansens is offline VBA Module for inserting images into Photo Album Windows 11 VBA Module for inserting images into Photo Album Office 2021
Novice
VBA Module for inserting images into Photo Album
 
Join Date: Oct 2022
Posts: 2
Jjansens is on a distinguished road
Default

Quote:
Originally Posted by macropod View Post
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.
Reply With Quote
  #4  
Old 10-07-2022, 02:29 PM
macropod's Avatar
macropod macropod is offline VBA Module for inserting images into Photo Album Windows 10 VBA Module for inserting images into Photo Album Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,856
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #5  
Old 11-16-2022, 08:02 AM
abosman abosman is offline VBA Module for inserting images into Photo Album Windows 10 VBA Module for inserting images into Photo Album Office 2021
Novice
 
Join Date: Nov 2022
Posts: 1
abosman is on a distinguished road
Default

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
Reply With Quote
  #6  
Old 11-18-2022, 03:43 PM
macropod's Avatar
macropod macropod is offline VBA Module for inserting images into Photo Album Windows 10 VBA Module for inserting images into Photo Album Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,856
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
Reply

Tags
photo album

Thread Tools
Display Modes


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
VBA Module for inserting images into Photo Album 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
VBA Module for inserting images into Photo Album 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
VBA Module for inserting images into Photo Album Help!!Need to apply same custom animation to all slides in a photo album. watsonstudios PowerPoint 3 05-27-2011 01:36 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 03:07 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2022, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2022 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft