Consulting

Results 1 to 2 of 2

Thread: Dynamic Image Adjustment

  1. #1
    VBAX Newbie
    Joined
    May 2021
    Posts
    3
    Location

    Exclamation Dynamic Image Adjustment

    Hello everyone, how are you?
    I hope everything goes good.

    A couple of weeks ago, i open a thread with a problem: adjust the same size to all the images in an active presentation withouth textboxes.
    The code worked, but now i have other problem. The images that i paste in each slide, has different dimensions what makes difficult the correct visualization of the slide. Now, i would to know if it's possible adjust all the images in the active slide dynamiclly.

    For example, i have 4 images in the active slide. These images have the same high size and cannot exceed 13 centimeters high. I want them to be distributed horizontally with a small space between them and without leaving the slide. If the sum of the widths is higher that the slide width, reduce all images. Like this:

    Captura.jpg

    The same situation when i paste 3,2 or 1 images. Ever the max images per slide will be 4.

    I hope i have explained well.
    It would be great if you can help me.

    Thanks.

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    You could start with this and play with it!

    Sub fixPic()
    Dim rayPic() As Shape
    Dim osld As Slide
    Dim opic As Shape
    Dim L As Long
    ReDim rayPic(1 To 1)
    Set osld = ActiveWindow.Selection.SlideRange(1)
    For Each opic In osld.Shapes
    If isPIC(opic) Then
    opic.Height = 100
    Set rayPic(UBound(rayPic)) = opic
    ReDim Preserve rayPic(1 To UBound(rayPic) + 1)
    End If
    Next opic
    rayPic(1).Left = 10
    rayPic(1).Top = 100
    rayPic(1).Select
    For L = 2 To UBound(rayPic) - 1
    rayPic(L).Left = rayPic(L - 1).Width + rayPic(L - 1).Left + 10
    rayPic(L).Top = 100
    rayPic(L).Select False
    Next L
    With ActiveWindow.Selection.ShapeRange.Group
    .LockAspectRatio = True
    .Width = ActivePresentation.PageSetup.SlideWidth - 20
    .Left = 10
    .Ungroup
    End With
    End Sub
    
    
    Function isPIC(opic As Shape) As Boolean
    If opic.Type = msoPicture Then isPIC = True
    If opic.Type = msoPlaceholder Then
    If opic.PlaceholderFormat.ContainedType = msoPicture Then isPIC = True
    End If
    End Function
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •