[PPT-2007] Les images ne se collent plus lors de la création d'un document

[savate-tung]

Bonjour et merci pour la réponse, j'ai pu avancé dans mon développement.

J'ai récupéré un code VBA pour créer un document PowerPoint contenant une série de plusieurs images "png" (stockés dans le répertoire ScreenShot)

Avant PowerPoint 2007, cela fonctionnait avec le code VBA suivant :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
 
Sub RecupScreenShot()
 
    DInit = Left(ActivePresentation.FullName, _
                 Len(ActivePresentation.FullName) - Len(ActivePresentation.Name) - 1)
    D = DInit & "\ScreenShot"
 
    On Error Resume Next
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
    If Err <> 0 Then
       Err = 0
    End If
 
    Set fs = Application.FileSearch
    With fs
    .LookIn = D
    .FileName = "*.png"
    If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
 
        For i = 1 To .FoundFiles.Count
 
            ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank).Select
 
            ActiveWindow.Selection.Unselect
 
            ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:= _
                  .FoundFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                  Left:=-23, Top:=-17, Width:=768, Height:=576).Select
 
            With ActiveWindow.Selection.ShapeRange
                .ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 0.91, msoFalse, msoScaleFromBottomRight
                .IncrementLeft 24#
                .IncrementTop -36.12
                .ScaleWidth 1.03, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 1.03, msoFalse, msoScaleFromTopLeft
            End With
 
            ActiveWindow.Selection.ShapeRange.Select
 
        Next i
 
    Else
        MsgBox "Pas de fichier trouvé."
    End If
    End With
 
    ActivePresentation.Save
 
End Sub

Avec l'aide des membres du forum, mon code a évolué en ceci :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
 
Sub RecupScreenShot()
 
    DInit = Left(ActivePresentation.FullName, _
                 Len(ActivePresentation.FullName) - Len(ActivePresentation.Name) - 1)
    D = DInit & "\ScreenShot"
 
    On Error Resume Next
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
    If Err <> 0 Then
       Err = 0
    End If
 
 
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
 
    With dlg
    .InitialFileName = D
    .Filters.Add "Images", "*.png", 1
    .AllowMultiSelect = True
    If .Show = -1 Then
 
 
    lLastSlide = ActivePresentation.Slides.Count
    If lLastSlide = 0 Then ActivePresentation.Slides.Add lLastSlide + 1, ppLayoutBlank
 
 
    For i = 1 To .SelectedItems.Count
 
            ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank).Select
 
            ActiveWindow.Selection.Unselect
 
            ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:= _
                  .FoundFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                  Left:=-23, Top:=-17, Width:=768, Height:=576).Select
 
            With ActiveWindow.Selection.ShapeRange
                .ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 0.91, msoFalse, msoScaleFromBottomRight
                .IncrementLeft 24#
                .IncrementTop -36.12
                .ScaleWidth 1.03, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 1.03, msoFalse, msoScaleFromTopLeft
            End With
 
            ActiveWindow.Selection.ShapeRange.Select
 
        Next i
 
    Else
        MsgBox "Pas de fichier trouvé."
    End If
    End With
 
    ActivePresentation.Save
 
End Sub

Le résultat c'est qu'il me créé mon document avec le nombre de pages corresponds aux nombres d'images "png" mais sans les images.

Pouvez-vous me donner un coup de main ?
Merci d'avance.

[pgz]

Bonsoir.

Tu pourrais là

Code :

1
2
3
ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:= _
                  .FoundFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                  Left:=-23, Top:=-17, Width:=768, Height:=576).Select

remplacer .FoundFiles(i) par .selectedItems(i)

L'objet FileDialog n'ayant pas de propriété FoundFiles, tu devrais avoir une erreur de compilation. Pourquoi même l'exécution ne lève pas d'erreur?

Par ailleurs, je ne sais plus, mais SelectedItems est une collection qui est peut-être indexée à partir de 0.

Pour éviter le pb, tu peux utiliser une boucle For each ... Next, plutôt qu'une boucle avec un compteur.

Cordialement,

PGZ