creation dynamique de ppt

Bonjour,

Une idée à creuser, puisque tu fait des PrintScreen, en déplaçant la fenêtre de haut en bas :

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
 
    Dim NBLignes As Integer
    Dim NBColonnes As Integer
    Dim LigneDebut As Integer
    Dim ColonneDebut As Integer
    Dim I As Integer
 
    'monte la feuille tout en haut de la fenêtre pour le début du PrintScreen
    ActiveWindow.ScrollRow = 1
 
    'fait une boucle ici 2 fois pour le test, à adapter
    For I = 1 To 2
 
        'ligne la plus en haut et colonne la plus à gauche de la fenêtre
        LigneDebut = ActiveWindow.VisibleRange.Row
        ColonneDebut = ActiveWindow.VisibleRange.Column
 
        'nombre de lignes et colonnes visibles dans la fenêtre (le total est pour l'adresse du range)
        NBLignes = ActiveWindow.VisibleRange.Rows.Count + LigneDebut
        NBColonnes = ActiveWindow.VisibleRange.Columns.Count + ColonneDebut
 
        'ajoute la diapo (dans le test, 2)
        Set Diapo = .Slides.Add(index:=I, Layout:=ppLayoutBlank)
 
        Sheets("Feuil1").Range(Cells(LigneDebut, ColonneDebut), Cells(NBLignes, NBColonnes)).CopyPicture xlScreen, xlBitmap
        Diapo.Shapes.Paste
 
        'déplace la fenêtre afin de faire le PrintScreen suivant
        ActiveWindow.ScrollRow = NBLignes - 1
 
   Next I

En l'intégrant dans ton code (index est à remplacer par I et zoneFin doit être utilisé pour connaître combien de fois il faudra Scroller pour tout récupérer). Pour tester, essai d'allerger au maximum ton code pour voir le résultat de l'exemple que je te donne (c'est ce que j'ai fait, voir code plus bas) :

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
 
Sub ajouterSlidePpt(fichier As String, onglet As String, index As Integer, zoneFin As String)
 
        Dim PptApp As PowerPoint.Application
        Dim PptDoc As PowerPoint.Presentation
        Dim Diapo As PowerPoint.Slide
        'Dim Cs1 As ColorScheme
        Dim Sh As PowerPoint.Shape
        Dim Shdate As PowerPoint.Shape
 
        Dim NBLignes As Integer
        Dim NBColonnes As Integer
        Dim LigneDebut As Integer
        Dim ColonneDebut As Integer
        Dim I As Integer
 
        'fonction permettant de vider le presse papier
        VidePP
 
        Set PptApp = CreateObject("Powerpoint.Application")
        Set PptDoc = PptApp.Presentations.Open(fichier)
 
        With PptDoc
 
            Set Diapo = .Slides.Add(index:=index, Layout:=ppLayoutBlank)
 
            Set Sh = .Slides(index).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
                Left:=100, Top:=20, Width:=150, Height:=60)
                Sh.TextFrame.TextRange.Text = "toto"
 
            Sh.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
            Sh.TextFrame.TextRange.Font.Size = 24
            Sh.TextFrame.TextRange.Font.Bold = True
 
            Set Shdate = .Slides(index).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
                Left:=300, Top:=500, Width:=150, Height:=60)
                Shdate.TextFrame.TextRange.Text = Format(Date, "dd/mm/yyyy")
                Shdate.TextFrame.TextRange.Font.Size = 9
                Shdate.TextFrame.TextRange.Font.Color = RGB(0, 0, 102)
 
            '>>>>> voir pour la plage ???
           'Sheets(onglet).Range("A1:" & zoneFin).CopyPicture xlScreen, xlBitmap
 
             'monte la feuille tout en haut de la fenêtre pour le début du PrintScreen
             ActiveWindow.ScrollRow = 1
 
             'fait une boucle ici 2 fois pour le test, à adapter
             For I = 1 To 2
 
                 'ligne la plus en haut et colonne la plus à gauche de la fenêtre
                 LigneDebut = ActiveWindow.VisibleRange.Row
                 ColonneDebut = ActiveWindow.VisibleRange.Column
 
                 'nombre de lignes et colonnes visibles dans la fenêtre (le total est pour l'adresse du range)
                 NBLignes = ActiveWindow.VisibleRange.Rows.Count + LigneDebut
                 NBColonnes = ActiveWindow.VisibleRange.Columns.Count + ColonneDebut
 
                 'ajoute la diapo (dans le test, 2)
                 Set Diapo = .Slides.Add(index:=I, Layout:=ppLayoutBlank)
 
                 Sheets("Feuil1").Range(Cells(LigneDebut, ColonneDebut), Cells(NBLignes, NBColonnes)).CopyPicture xlScreen, xlBitmap
                 Diapo.Shapes.Paste
 
                 'déplace la fenêtre afin de faire le PrintScreen suivant
                 ActiveWindow.ScrollRow = NBLignes - 1
 
            Next I
 
            .Save
 
        End With
 
        PptDoc.Close
        PptApp.Quit
 
End Sub

Ce avec quoi j'ai fait un test :

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
 
Sub ajouterSlidePpt()
 
    Dim PptApp As PowerPoint.Application
    Dim PptDoc As PowerPoint.Presentation
    Dim Diapo As PowerPoint.Slide
    'Dim Cs1 As ColorScheme
    Dim Sh As PowerPoint.Shape
    Dim Shdate As PowerPoint.Shape
    Dim NBLignes As Integer
    Dim NBColonnes As Integer
    Dim LigneDebut As Integer
    Dim ColonneDebut As Integer
    Dim I As Integer
 
    'fonction permettant de vider le presse papier
    Application.CutCopyMode = False
 
    Set PptApp = New PowerPoint.Application
    Set PptDoc = PptApp.Presentations.Add '<< ici un fichier est ajouté !!!
 
    PptApp.Visible = True
 
    With PptDoc
 
        'monte la feuille tout en haut de la fenêtre pour le début du PrintScreen
        ActiveWindow.ScrollRow = 1
 
        'fait une boucle ici 2 fois pour le test, à adapter
        For I = 1 To 2
 
            'ligne la plus en haut et colonne la plus à gauche de la fenêtre
            LigneDebut = ActiveWindow.VisibleRange.Row
            ColonneDebut = ActiveWindow.VisibleRange.Column
 
            'nombre de lignes et colonnes visibles dans la fenêtre (le total est pour l'adresse du range)
            NBLignes = ActiveWindow.VisibleRange.Rows.Count + LigneDebut
            NBColonnes = ActiveWindow.VisibleRange.Columns.Count + ColonneDebut
 
            'ajoute la diapo (dans le test, 2)
            Set Diapo = .Slides.Add(index:=I, Layout:=ppLayoutBlank)
 
            Sheets("Feuil1").Range(Cells(LigneDebut, ColonneDebut), Cells(NBLignes, NBColonnes)).CopyPicture xlScreen, xlBitmap
            Diapo.Shapes.Paste
 
            'déplace la fenêtre afin de faire le PrintScreen suivant
            ActiveWindow.ScrollRow = NBLignes - 1
 
        Next I
 
    End With
 
End Sub

Hervé.