Power Point VBA - Importer 4 images par diapo

Yurperqod

XLDnaute Occasionnel
Bonjour à tous

J'ai une macro pour importer une image par diapo en sélectionnant un dossier.
VB:
Sub PowerPoint_Import()
Dim ImgI As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
  If .Show = -1 Then
  For ImgI = 1 To .SelectedItems.Count
  Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutTitleOnly)
  tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
  LinkToFile:=msoFalse, _
  SaveWithDocument:=msoTrue, _
  Left:=10, Top:=22, _
  Width:=700, Height:=500
  Next
  End If
  End With
End Sub

J'ai 140 images dans un dossier (JPG:format 800*600)
Je voudrais mettre 4 images par diapos

Je n'arrive pas à modifier la macro PowerPoint_Import pour le faire.

Est-ce que vous voyez comment faire ?
 

Yurperqod

XLDnaute Occasionnel
Bonjour à tous,

J'ai trouvé une solution sans macro avec l'option Photo-Album dans Powerpoint.

Mais comme on peut pas enregistrer de macro, j'arrive pas à le faire en VBA.

Est-ce que quelqu'un peut à trouver comme faire cette macro ?
 

Dranreb

XLDnaute Barbatruc
Bonsoir.
Complètement à l'aveugle pour moi, essayez peut être ça, à tout hasard :
VB:
Sub PowerPoint_Import()
Dim ImgI As Long, K As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
   .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
   If .Show = -1 Then
      For ImgI = 1 To .SelectedItems.Count
         If K = 0 Then
            Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI \ 4 + 1, _
               Layout:=ppLayoutTitleOnly)
            End If
         tmpDIAPO.Shapes.AddPicture Filename:=.SelectedItems.Item(ImgI), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=10 + (K Mod 2) * 800, Width:=700, _
            Top:=22 + (K \ 2) * 600, Height:=500
         K = (K + 1) Mod 4
         Next ImgI
      End If
   End With
End Sub
 

Yurperqod

XLDnaute Occasionnel
Bonjour à tous

Merci Dranreb,
Grâce à toi c'est presque bon ;)
(Il me reste à régler l'espace entre les images au milieu de la diapo)
Je me suis aperçu qu'il faut renseigner les dimensions en points et pas en pixel, ce que j'ai fait dans la macro du début
Voila où j'en suis grâce à toi
VB:
Sub PowePoint_Import_4IMGDiapo()
Dim ImgI As Long, K As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
If .Show = -1 Then
For ImgI = 1 To .SelectedItems.Count
If K = 0 Then
Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI \ 4 + 1, _
Layout:=ppLayoutTitleOnly)
End If
tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=88.44 + (K Mod 2) * 354, Width:=354, _
Top:=0 + (K \ 2) * 265.5, Height:=265.5
K = (K + 1) Mod 4
Next ImgI
End If
End With
End Sub
 

bluesky12000

XLDnaute Junior
Malheureusement c'est ce que je fais depuis plusieurs heures :)
Tous les codes que je rencontre créés de nouvelles slides. J'ai déjà mes slides de créées je cherche donc juste à ajouter les images les unes après les autres.

Je bloque sur cette ligne

VB:
  Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutTitleOnly)

Si je la remplace par ActivePresentation.Slides(1), ca va bien sur la première slide mais dans ce cas tout va dessus.

Edit : je viens de comprendre que je pouvais mettre ActivePresentation.Slides(ImgI). Par contre j'ai testé si ImgI est supérieur au nombre de slides alors cela créé une erreur.

Il faudrait que je puisse écrire une condition comme :

If ImgI > ActivePresentation.Slides.Count then ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutTitleOnly)
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Salut, pour 1 Image / Diapo il reste ceci ( Chemin strPath et type de fichier strFileSpec à adapter )
VB:
Option Explicit

Sub Import_1_Pict()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

    strPath = ActivePresentation.Path & "\" & "Diapos Unitaires" & "\"
    strFileSpec = "*.tif"
    strTemp = Dir$(strPath & strFileSpec)

    Do While strTemp <> ""
        Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)

        Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
                                          LinkToFile:=msoFalse, _
                                          SaveWithDocument:=msoTrue, _
                                          Left:=0, _
                                          Top:=0, _
                                          Width:=-1, _
                                          Height:=-1)

        oPic.Width = ActivePresentation.PageSetup.SlideWidth
        oPic.Left = 0
        oPic.Top = 0

        strTemp = Dir$
    Loop
End Sub
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Re, avec cette recherche j'aboutis à ceci pour 4 Images / Diapo :

VB:
Option Explicit

Sub Import_4_Pictures()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim lCurrentRound As Long

    lCurrentRound = 1

    strPath = ActivePresentation.Path & "\" & "Diapos Unitaires" & "\"
    strFileSpec = "*.tif"
    strTemp = Dir$(strPath & strFileSpec)

    Do While strTemp <> ""
        If lCurrentRound = 1 Then
            Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)
        End If

        Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
                                          LinkToFile:=msoFalse, _
                                          SaveWithDocument:=msoTrue, _
                                          Left:=0, _
                                          Top:=0, _
                                          Width:=-1, _
                                          Height:=-1)

        oPic.Width = ActivePresentation.PageSetup.SlideWidth / 2

        Select Case lCurrentRound
        Case 1
            oPic.Left = 0
            oPic.Top = 0
        Case 2
            oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
            oPic.Top = 0
        Case 3
            oPic.Left = 0
            oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2
        Case 4
            oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
            oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2
        End Select

        If lCurrentRound = 4 Then
            lCurrentRound = 1
        Else
            lCurrentRound = lCurrentRound + 1
        End If

        strTemp = Dir$
    Loop
End Sub
 

Pièces jointes

  • 3.png
    3.png
    101.5 KB · Affichages: 47
Dernière édition:

Statistiques des forums

Discussions
311 720
Messages
2 081 886
Membres
101 830
dernier inscrit
sonia poulaert