'### Constantes des dimensions maxi (à adapter) ###
Const MAX_HAUTEUR_CM As Long = 11
Const MAX_LARGEUR_CM As Long = 22
'##################################################
Sub SetDimensionsMax(R As Range)
Dim maxHeight As Double
Dim maxWidth As Double
Dim PIC As Excel.Picture
'--- Copie la plage de la feuille concernée ---
R.CopyPicture xlScreen, xlPicture
'--- On sauve (dans Excel) dans une Picture ---
ActiveSheet.Paste
Set PIC = Selection
'--- Conversion des maxis (cm => points) ---
maxHeight = Application.CentimetersToPoints(MAX_HAUTEUR_CM)
maxWidth = Application.CentimetersToPoints(MAX_LARGEUR_CM)
'--- Si on excède les maxis, on fixe les dimensions aux maxis ---
If PIC.Height > maxHeight Then PIC.Height = maxHeight
If PIC.Width > maxWidth Then PIC.Width = maxWidth
'--- Copie de la Picture (on obtient la bonne image dans le presse-papiers)---
PIC.CopyPicture
'--- Nettoyage ---
PIC.Delete
End Sub
Sub MesImages()
Dim PP As Object 'PowerPoint.Application
Dim P As Object 'PowerPoint.Presentation
Dim S As Object 'PowerPoint.Slide
Dim i&
'---
Application.ScreenUpdating = False
'--- Pour l'exemple, on construit une Application PowerPoint ---
Set PP = CreateObject(Class:="Powerpoint.Application")
'--- Pour l'exemple, on crée une Présentation ---
Set P = PP.Presentations.Add
PP.Visible = True
PP.ActiveWindow.ViewType = 1 '1 = ppViewSlide
'--- Pour l'exemple, on construit 6 Diapositives ---
For i& = 1 To 6
Set S = P.Slides.Add(i&, 12) '12 = ppLayoutBlank
Next i&
'--- Collage des images ---
P.Slides(4).Select
Call SetDimensionsMax(Sheets("WBR TDB1").Range("C3:S26")) 'on passe le paramètre Range avec son Parent Worksheet
PP.ActiveWindow.View.Paste
P.Slides(5).Select
Call SetDimensionsMax(Sheets("WBR TDB2").Range("C3:S31")) 'idem
PP.ActiveWindow.View.Paste
P.Slides(6).Select
Call SetDimensionsMax(Sheets("WBR TDB3").Range("C3:F27")) 'idem
PP.ActiveWindow.View.Paste
'--- Nettoyage ---
Set PP = Nothing
Application.ScreenUpdating = True
End Sub