Dimensionner image en vba pour export vers PowerPoint

[nauj]

Bonjour Forum,
Je m'adresse à vous pour un éclairage sur la façon de déclarer le dimensionnement d'une image en code vba avant export vers un fichier PPT.
Le code ci-dessous fonctionne parfaitement, mes 3 tableaux sont bien insérés dans un fichier PPT en revanche leurs dimensions dépassent largement celles des slides.
Ma question est la suivante : comment déclarer sur le code vba que l'image créée doit avoir une largeur qui ne doit pas dépasser 11cm (ça peut être inférieur), que la longueur qui ne doit pas dépasser 22cm (ça peut être également inférieur) et doit toujours être centrée verticalement sur le slide ?
Bonnes fêtes !

Code vba :
Sub MesImages ()

Application.ScreenUpdating = False

Dim PPApp As PowerPoint.Application
Set PPApp = GetObject(Class:="Powerpoint.Application")
PPApp.ActiveWindow.ViewType = ppViewSlide

PPApp.ActivePresentation.Slides(4).Select
Sheets("WBR TDB1").Range("C3:S26").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.View.Paste

PPApp.ActivePresentation.Slides(5).Select
Sheets("WBR TDB2").Range("C3:S31").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.View.Paste

PPApp.ActivePresentation.Slides(6).Select
Sheets("WBR TDB3").Range("C3:F27").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.View.Paste

Set PPApp = Nothing

Application.ScreenUpdating = True

End Sub

 

[PMO2]

Re : Dimensionner image en vba pour export vers PowerPoint

Bonjour,

Une piste avec le code suivant à copier dans un module Standard

'### 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

L'exemple crée une nouvelle Application PowerPoint avec une Présentation et 6 Diapositives.

 

[nauj]

Re : Dimensionner image en vba pour export vers PowerPoint

Bonsoir PM02, Forum,
Tout d'abord, je vous souhaite une excellente année 2014 !
Je vous remercie pour ce code qui fonctionne parfaitement. Je vais en revanche l'adapter pour que les copies d'image s'effectuent avec un document PPT ouvert au préalable.
Bonne continuation et à bientôt
Nauj

 

[nauj]

Re : Dimensionner image en vba pour export vers PowerPoint

Bonsoir PM02, Forum,
J'ai cherché à adapter ton code avec l'objectif de coller les images sur un document PPT ouvert au préalable et j'ai un retour en erreur en pointant sur la ligne :
ActiveSheet.Paste
Si vous avez une idée de la solution, je suis preneur !
A bientôt
Nauj

 

[nauj]

Re : Dimensionner image en vba pour export vers PowerPoint

PM02, Forum,
J'ai trouvé d'où venait le problème... Le "call" était positionné sur un des onglets à copier. Dès lors qu'il a été mis sur un autre onglet, tout a fonctionné.
Merci encore pour tout
A bientôt
Nauj

 

[PMO2]

Re : Dimensionner image en vba pour export vers PowerPoint

Bonjour et meilleurs voeux pour 2014,

J'ai cherché à adapter ton code avec l'objectif de coller les images sur un document PPT ouvert au préalable et j'ai un retour en erreur en pointant sur la ligne :
ActiveSheet.Paste
Si vous avez une idée de la solution, je suis preneur !

Ce problème survient pour diverses raisons : sélection autre qu'un range, feuille protégée, etc.
Pour y remédier, il suffit de créer une nouvelle feuille temporaire qui sera donc vide de tout puis de la supprimer à la fin de la routine. Ci-dessous, le code amélioré qui prend en compte ce traitement. Les ajouts sont signalés entre des '///

'### 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 WStempo As Worksheet
'///

Dim PP As Object   'PowerPoint.Application
Dim P As Object    'PowerPoint.Presentation
Dim S As Object    'PowerPoint.Slide
Dim i&
'---
Application.ScreenUpdating = False

'///
'--- Une nouvelle feuille est créée ---
Set WStempo = Sheets.Add
'///

'--- 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

'///
If Not WStempo Is Nothing Then
  Application.DisplayAlerts = False
  WStempo.Delete
  Application.DisplayAlerts = True
  Set WStempo = Nothing
End If
'///

Application.ScreenUpdating = True
End Sub

 

[nauj]

Re : Dimensionner image en vba pour export vers PowerPoint

Bonjour PM02, Forum,
Adaptation impeccable !
Merci encore pour le temps que tu as bien voulu consacrer à mon problème
Je considère ce fil comme terminé
A bientôt
Nauj