[PPT-2003] Trouver l'image ou les images les plus lourdes d'un document

Suite à un précédent message, je mets à disposition de la communauté ce morceau de code qui remplit mon besoin d'être capable de trouver les images volumineuses d'un powerpoint pour pouvoir en diminuer la taille au besoin...

Question : existe-t-il un tableau qui donnerait pour chaque n° de type d'image au sens VBA, ce à quoi ça correspond ? je suppose que oui mais je ne l'ai pas trouvé.

Cdlt
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
Sub Extraction_des_images()
 
' Principe = on colle chaque image dans une diapo d'une présnetation dont on "mesure" l'évolution de la taille
' Par différence avec la précédente "mesure" de la taille de la présentation,
' on obtient approximativement le poids de ce qui a été collé ==> l'image
 
    Dim fso
    Dim Dir
    Dim fs, myFile As Object
    Dim myPres As Presentation
    Dim myDraft As Presentation
    Dim myDraftName As String
    Dim x, I, J, typ As Integer
    Dim aSize, h, W, taille, taille2 As Long
    Dim compteur, compteur2, compteur3 As Integer
 
 
'TEST DE L'EXISTANCE DU DOSSIER D'EXTRACTION PUIS CREATION EN CAS ECHEANT
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists("C:\Extraction_images_PPT") Then GoTo Label1
Set Dir = fso.CreateFolder("C:\Extraction_images_PPT")
On Error Resume Next
Label1:
'fin de test ou de création des dossiers
 
    Set myPres = ActivePresentation
    Set myDraft = Presentations.Add
    myDraftName = "C:\Extraction_images_PPT\Extract_images_" & Format(Date, "yyyy-m-d") & Format(Time, "_hh-mm-ss") & "_" & ActivePresentation.Name
 
    With Application.ActivePresentation
    .SaveAs myDraftName
    End With
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set myFile = fs.GetFile(myDraft.FullName)
 
 
compteur = 0
compteur2 = 0
compteur3 = 0
x = 0
For I = 1 To myPres.Slides.Count
'Sélection de la diapo et comptage du nombre de "shapes" de la diapo
    myPres.Slides(I).Select
    For J = 1 To myPres.Slides(I).Shapes.Count
'Sélection de la "shapes limitée à différents types d'image"
If myPres.Slides(I).Shapes(J).Type = 6 Or myPres.Slides(I).Shapes(J).Type = 11 Or myPres.Slides(I).Shapes(J).Type = 13 Then
x = x + 1
    typ = myPres.Slides(I).Shapes(J).Type
' Récupération de la hauteuret de la largeur de l'image pour calcul du rapport Poids en Ko / Surface
' 28,32 est le coefficient entre ppi et cm (je pense)
    h = myPres.Slides(I).Shapes(J).Height / 28.32
    W = myPres.Slides(I).Shapes(J).Width / 28.32
    myPres.Slides(I).Shapes(J).Copy
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=x, Layout:=ppLayoutTitle).SlideIndex
    ActiveWindow.Selection.SlideRange.Shapes.SelectAll
    ActiveWindow.Selection.ShapeRange.Delete
 
    ActiveWindow.View.Paste
    ActivePresentation.Save
 
    taille = (myFile.Size - compteur) / 1024
    If (h * W) = 0 Then
    taille2 = taille
    GoTo label20
    End If
 
    taille2 = Format(taille / (h * W), "####0.00")
 
 
label20:
    compteur = myFile.Size
    compteur2 = compteur2 + taille
 
cible = 5
' je fixe arbitrairement l'extraction de tout ce qui sera supérieur à 5 Ko/cm2
        If taille2 < cible Then
        ActiveWindow.View.Slide.Delete
        x = x - 1
        compteur3 = compteur3 + taille
        GoTo Label2
        End If
 
' je crée une zone de texte pour pour pouvoir écrire quelques informations (n° de la diapo concernée, poids, rapport poids surface et type d'image.
    ActiveWindow.Selection.SlideRange.Shapes.AddLabel(msoTextOrientationHorizontal, -7.25, -0.625, 14.5, 28.875).Select
    ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoFalse
    With ActiveWindow.Selection.TextRange.ParagraphFormat
        .LineRuleWithin = msoTrue
        .SpaceWithin = 1
        .LineRuleBefore = msoTrue
        .SpaceBefore = 0.5
        .LineRuleAfter = msoTrue
        .SpaceAfter = 0
    End With
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
' défintion exacte du texte qui sera collé dans la forme
    With ActiveWindow.Selection.TextRange
        .Text = "Slide n° " & I & ".   Poids = " & taille & " Ko.   Rapport Poids/Surface :  " & taille2 & " Ko/cm2.   ( Type = " & typ & " )"
        With .Font
            .Name = "Arial"
            .Size = 18
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppForeground
        End With
    End With
    ActiveWindow.Selection.ShapeRange.ZOrder msoBringToFront
 
Label2:
 
    ActiveWindow.Selection.Unselect
 
End If
 
    Next J
Next I
 
MsgBox "Cumul des tailles de toutes les images = " & compteur2 & ". Cumul des " & x & "  images extraites = " & compteur2 - compteur3
 
End Sub