Insert/Resize pic in PowerPoint 2010 through VBA

[RonRepp]

Hi, all:

Another day, another problem to solve.

My client originally handed me an XL spreadsheet w/pics pasted into it as well as 2 other columns--1 for the text in the header and 1 for the text in the text box.

I told him it would be easier to just use a reference path for the pics and then they wouldn't be "soft" (out of focus), because through code you can only CopyPicture and then paste as a metafile (If I'm wrong, tell me, please)

The reference path adds a more robust image, the problem is that now some of the pics are too large and overlap the TextBox. So, I felt by resizing the pics (as shown below) would do it. Unfortunately, it makes it look like a thumbnail.

Dim TBTop As Integer, TBH As Integer, TBW As Integer, TBLeft As Integer
Dim PicTop As Integer, PicHeight As Integer, PicWidth As Integer, PicLeft As Integer
    
Set ActiveSlide = PP.ActivePresentation.Slides(4)
    With ActiveSlide.Shapes("TextBox 3")
       TBTop = .Top
       TBH = .Height
       TBW = .Width
       TBLeft = .Left
    End With
    With ActiveSlide.Shapes("Picture 4")
       PicTop = .Top
       PicHeight = .Height
       PicWidth = .Width
       PicLeft = .Left
    End With
    
    If ActiveSlide.Shapes("Picture 4").Width > TBLeft Then
        ActiveSlide.Shapes("Picture 4").Height = (ActiveSlide.Shapes("Picture 4").Height / 2)
        ActiveSlide.Shapes("Picture 4").Width = (ActiveSlide.Shapes("Picture 4").Width / 2)
    End If
    
    ActiveSlide.Shapes("Picture 4").Top = (ActiveSlide.Shapes("Textbox 3").Height - ActiveSlide.Shapes("Picture 4").Height / 2)

Any help will be greatly appreciated.

Thanks,


Ron Repp

If gray hair is a sign of wisdom, then I'm a genius.

My newest novel: Wooden Warriors

http://www.repproductions.net

 

[RonRepp]

OK, figured it out.

Sub CenterPictureInCol1()
    Dim TBTop As Integer, TBH As Integer, TBW As Integer, TBLeft As Integer
    Dim PicTop As Integer, PicHeight As Integer, PicWidth As Integer, PicLeft As Integer
    
    Set ActiveSlide = PP.ActivePresentation.Slides(4)

    With ActiveSlide.Shapes("TextBox 3")
       TBTop = .Top
       TBH = .Height
       TBW = .Width
       TBLeft = .Left
    End With
    
    With ActiveSlide.Shapes("Picture 4")
       PicTop = .Top
       PicHeight = .Height
       PicWidth = .Width
       PicLeft = .Left
    End With
    
    Dim NewWidth As Long
    Dim NewHeight As Long
    
    
    ''keep the aspect ratio even
    If ActiveSlide.Shapes("Picture 4").Width > TBLeft Then
        NewWidth = Abs(TBLeft - ActiveSlide.Shapes("Picture 4").Width)
        ActiveSlide.Shapes("Picture 4").Height = ActiveSlide.Shapes("Picture 4").Height - (NewWidth / 2)
        ActiveSlide.Shapes("Picture 4").Width = ActiveSlide.Shapes("Picture 4").Width - (NewWidth / 2)
    End If
    
    ActiveSlide.Shapes("Picture 4").Top = (ActiveSlide.Shapes("Textbox 3").Top + (ActiveSlide.Shapes("Textbox 3").Height / 2))
    ActiveSlide.Shapes("Picture 4").Left = NewWidth / 2
End Sub

Ron Repp

If gray hair is a sign of wisdom, then I'm a genius.

My newest novel: Wooden Warriors

http://www.repproductions.net