Power Point VBA - Importer 4 images par diapo

[Yurperqod]

Bonjour à tous

J'ai une macro pour importer une image par diapo en sélectionnant un dossier.

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]

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 ?

 

[Yurperqod]

Bonjour à tous

Je relance la discussion.

Je bloque toujours pour faire en macro ce qu'on peut faire avec la fonction AlbumPhoto.

Je veux passer par VBA parce que quand il y a beaucoup de photos powerpoint rame enormement.

 

[Yurperqod]

Bonjour à tous

Je relance la discussion.

Est-ce que quelqu'un voit comment faire ?
Merci.

 

[Yurperqod]

Bonjour à tous

Je relance la discussion.

 

[Dranreb]

Bonsoir.
Complètement à l'aveugle pour moi, essayez peut être ça, à tout hasard :

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]

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

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]

Bonjour à tous,

Je déterre ce topic car j'aimerai adapter le premier code de Yurperqod pour que les photos s'ajoutent les unes après autres à partir du premier slide existant.
Actuellement le code créé de nouveaux slides

Merci beaucoup,

 

[kiki29]

Salut, une recherche ?

 

[bluesky12000]

Salut, une recherche ?

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

  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)

 

[kiki29]

Salut, pour 1 Image / Diapo il reste ceci ( Chemin strPath et type de fichier strFileSpec à adapter )

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

 

[kiki29]

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

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