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 |
Partager