VBA resizing pictures to fit slides

[Olivier B]

Hello !!
I'm doing a lot of presentations using my Excel workbook as base.
So, I've written a code to copy each of my sheets, convert them in pictures
and paste in POWERPOINT.
I use the same 1st page in my presentations and the same conception model so
I work with the same powerpoint file as base for all presentations created
from Excel.

That's means the code I need can be created in Powerpoint OR Excel, no
matters as only the End result worth of effort.

My QUESTION :
---> How can I manage to resize every picture to fit Slides Dimension in VBA ?

Please keep in mind pictures contains figures that need to be read so i
whish if it is possible to keep a relation in-between width and height.

Thank you very much to help me !!!

Here is my VBA code I've writen in Excel; but the resizing code can be done
in VBA POWERPOINT, no matters, that's why I'm posting here....
---------------------------------------------
Sub copyinpowerpoint()
Dim pPoint As PowerPoint.Application
Dim dPoint As PowerPoint.Presentation
Set pPoint = New PowerPoint.Application
pPoint.Visible = True
Set dPoint = pPoint.Presentations.Open("D:\my.ppt")
Set Diapo2 = .Slides.Add(Index:=2, Layout:=ppLayoutBlank)
Sheets("sheet1").UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Diapo2.Shapes.Paste

 

[Olivier B]

For those that are interested here is my working codes....
All is perfect !!!
Thanks to all those that have tried to help me !!!

Now every one can go from a bunch of graphics, pivot tables and others... to
a real cool powerpoint !!!
You can customize your powerpoint masks so that it fit your firm Brand
Communication.

Enjoy !!!

Sub copierpowerpoint()
Dim tabl, graph As String
Dim i, j As Integer
Dim MaxFeuil, MaxGraph As Integer
Dim pPoint As PowerPoint.Application
Dim dPoint As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim shPoint As PowerPoint.Shape
'
'Les maximums : Nombre de feuilles de calculs et de graphiques utilisés.
MaxFeuil = Sheets("Guideline").Range("F18")
MaxGraph = Sheets("Guideline").Range("F29")
'
'******************* Création du powerpoint et Page de garde
Set pPoint = New PowerPoint.Application
pPoint.Visible = True
Set dPoint = pPoint.Presentations.Open(Filename:=ThisWorkbook.Path &
"\Ultimate_Presentation.ppt", ReadOnly:=True)
With dPoint
'--- Ajoute la diapo de présentation avec les titres et dates qui
conviennent
Set Diapo = .Slides.Add(Index:=1, Layout:=ppLayoutTitle)
Set shPoint = .Slides(1).Shapes.Title
shPoint.TextFrame.TextRange.Text =
Sheets("presentation").Range("C13").Value
'
'******************* Les Tableaux croisés (base=B18 - limite B26)
j = 1
' Prise en compte du nom des onglets
For i = 18 To (17 + MaxFeuil)
j = j + 1
tabl = Sheets("Guideline").Range("B" & i).Value
Set Diapo = .Slides.Add(Index:=j, Layout:=ppLayoutBlank)
With Diapo.Shapes
Sheets(tabl).UsedRange.CopyPicture
Appearance:=xlScreen, Format:=xlPicture
Set opicture = .Paste
opicture.ScaleHeight 1, msoTrue
opicture.ScaleWidth 1, msoTrue
opicture.Fill.Transparency = 0#
opicture.Left = 10#
opicture.Top = 0#
If 3 * opicture.Width > 4 * opicture.Height Then
opicture.Width = 700
opicture.Top = 70
'opicture.Top = 0.5 * (550 - opicture.Height)
Else
opicture.Height = 530
opicture.Left = 0.5 * (700 - opicture.Width)
End If
End With
Next i


'******************* Les GRAPHIQUES maintenant
j = MaxFeuil + 1
If MaxGraph > 0 Then
For i = 29 To (28 + MaxGraph)
graph = Sheets("Guideline").Range("B" & i).Value
j = j + 1
Set Diapo = .Slides.Add(Index:=j, Layout:=ppLayoutBlank)
With Diapo.Shapes
Sheets(graph).Range("A1:L50").CopyPicture
Appearance:=xlScreen, Format:=xlPicture
Set opicture = .Paste
opicture.ScaleHeight 1, msoTrue
opicture.ScaleWidth 1, msoTrue
opicture.Fill.Transparency = 0#
opicture.Left = 10#
opicture.Top = 0#
If 3 * opicture.Width > 4 * opicture.Height
Then
opicture.Width = 700
opicture.Top = 70
Else
opicture.Height = 530
opicture.Left = 0.5 * (700 -
opicture.Width)
End If
End With
Next i
ElseIf MaxGraph = 0 Then
End If
End With
End Sub