Consulting

Results 1 to 4 of 4

Thread: Macro to Resize/Position Pictures, Update Links & send to back, and save as PDF

  1. #1
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location

    Macro to Resize/Position Pictures, Update Links & send to back, and save as PDF

    Greetings,

    We use PPT for our reporting, and I am trying to find a way to expedite our reporting process. Currently, I have designed a Excel that I can import as an object to automate names, equations, etc. However, I need to insert shapes to cover up the extra text it leaves for the different parts of the report.

    My problem/question: I need to have my macro adjust only the pictures in slide 2 to the below size and position, then only the pictures in every other slide to the larger size and position. Next, I need the Excel linked objects to be sent to back and update the links. If there is any way to do something like the excel function in PPT like this one
    Application.ScreenUpdating = False
    , that would be ideal as well. Lastly, I would like for it to go ahead and open the "Save As-PDF" window.

    Thank you in advance for your time! Here is what I have at the present time:
    Sub FinalizeReport()
    
    
    Dim opic As Shape
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If opic.Type = msoPicture Then
    
    
    Dim opic As Shape
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If opic.Type = msoPicture Then
    With opic
    .Left = 7.2
    .Top = 40
    .LockAspectRatio = msoFalse
    .Width = 705.6
    .Height = 305
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    .Line.Weight = 1
    .ZOrder (msoSendToBack)
    End With
    End If
    Next opic
    Next osld
    Function cm2Points(inVal As Single)
    cm2Points = inVal * 28.346
    End Function
    
    
    ActivePresentation.Slides(2).Select
    With ActiveWindow.opic
    .LockAspectRatio = msoFalse
    .Height = 306.72
    .Width = 195.12
    .Left = 409.68
    .Top = 40.32
    .ZOrder (msoSendBackward)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    
    
    Dim osld As Slide
    Dim oshp As Shape
    For Each osld In ActivePresentation.Slides
    For Each oshp In osld.Shapes
    If oshp.Type = msoLinkedOLEObject Then oshp.LinkFormat.Update
    If oshp.Type = msoLinkedOLEObject Then .ZOrder (msoSendToBack)
    Next oshp
    Next osld
    End Function
    
    
    End Sub

  2. #2
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    I tried adjust ting the macro to the following, but was still unable to get it to work:
    Sub picsize()
    
    
    ActivePresentation.Slides(2).Select
    With ActiveWindow.opic
    .LockAspectRatio = msoFalse
    .Height = 306.72
    .Width = 195.12
    .Left = 409.68
    .Top = 40.32
    .ZOrder (msoSendBackward)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    
    
    ActivePresentation.Slides.Range (Array(3, 4, 5, 6, 7))
    
    
    Dim opic As Shape
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If opic.Type = msoPicture Then
    With opic
    .Left = 7.2
    .Top = 40
    .LockAspectRatio = msoFalse
    .Width = 705.6
    .Height = 305
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    .Line.Weight = 1
    .ZOrder (msoSendToBack)
    End With
    End If
    Next opic
    Next osld
    Function cm2Points(inVal As Single)
    cm2Points = inVal * 28.346
    End Function
    
    
    Dim osld As Slide
    Dim oshp As Shape
    For Each osld In ActivePresentation.Slides
    For Each oshp In osld.Shapes
    If oshp.Type = msoLinkedOLEObject Then oshp.LinkFormat.Update
    If oshp.Type = msoLinkedOLEObject Then .ZOrder (msoSendToBack)
    Next oshp
    Next osld
    End Function
    
    
    End Function
    Help would be greatly appreciated.

  3. #3
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    After digging in further in other threads, I think that I was able to refine the code a little more, and it is able to run without any errors. However, it still doesn't adjust the pictures as I need it to, it just updates the links in the ppt. What am I missing that is keeping it from updating my pictures/images?
    Here's the latest code:

    Sub Update_Images()
    
    Dim opic As Shape
    Dim nn As Integer
    
    
    'Updates the picture in slide 2 to desired shape/size/position
    For Each opic In ActivePresentation.Slides(2).Shapes
    If opic.Type = msoPicture Then
    With opic
    .LockAspectRatio = msoFalse
    .Height = 306.72
    .Width = 195.12
    .Left = 409.68
    .Top = 40.32
    .ZOrder (msoSendBackward)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    Else 'do nothing
    End If
    Next
    
    
    'Code designed for slides 3-9 where if there is a picture, then it'll adjust pictures to desired shape/size/position, & if there aren't any pictures, it moves on to next slide/part of macro.
    For nn = 3 To 9
    For Each opic In ActivePresentation.Slides(nn).Shapes
    If opic.Type = msoPicture Then
    With opic
    .Left = 7.2
    .Top = 40
    .LockAspectRatio = msoFalse
    .Width = 705.6
    .Height = 305
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    .Line.Weight = 1
    .ZOrder (msoSendToBack)
    End With
    Else 'do nothing
    End If
    Next
    Next
    
    
    'Updates links in Powerpoint as needed, but is there a way to send them to back?
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If opic.Type = msoLinkedOLEObject Then opic.LinkFormat.Update
    Next opic
    Next osld
    
    
    End Sub
    Last edited by Baiano42; 07-22-2019 at 11:15 PM.

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Checking that the shape type is msoPicture will not work if the picture is in a placeholder.

    Check for a Placeholder and then check it's ContainedType for msoPicture.

    Sub FinalizeReport()
    Dim opic As Shape
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If isPic(opic) Then
    Select Case osld.SlideIndex
    Case Is = 2
    'set slide 2 size
    Case Is > 2
    'set size for these
    End Select
    End If ' is a picture
    End Sub
    
    
    Function isPic(oshp As Shape) As Boolean
    If oshp.Type = msoPicture Then
    isPic = True
    Exit Function
    End If
    If oshp.Type = msoPlaceholder Then
    If oshp.PlaceholderFormat.ContainedType = msoPicture Then isPic = True
    End If
    End Function
    Last edited by John Wilson; 07-23-2019 at 06:44 AM.
    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
  •