Réduire la taille d'images sans nuire à la qualité d'affichage à l'écran

[ouskel'n'or]

But de la procédure :
Réduire les dimensions des fichiers images sans modifier la qualité d'affichage à l'écran.
Cette réduction dépend de la définition d'écran.
La qualité finale dépendra de cette définition (réalisé sur écran en 1280 * 1024 la qualité sera meilleure que réalisé en 1024 * 768)

L'intérêt de la chose :
Insérer des photos, des images, dans les documents sans en augmenter inconsidérément la taille.
Envoyer plus de photos par mail sans nuire à la qualité d'affichage à l'écran.

Restriction :
A ne pas utiliser pour une projection sur grand écran.

Le principe :
- Afficher l'image en plein écran dans PowerPoint
- Réaliser une copie d'écran
- Sauvegarder cette copie en tant que .jpg

La méthode :
Dans PowerPoint, Arrière-plan des diapositive noir.
Début de la boucle
- Lister les photos d'un répertoire et ses sous-répertoires
- Créer une image de la structure des répertoires dont le parent est renommé
Important :
En l'état, le répertoire "parent" de l'image doit exister ("D:\VERLEINE\" dans l'exemple) (voir création auto dans le second post)

- Ouvrir Excel
- Ajouter une feuille de calculs
- Dans PowerPoint, insérer une image dans la diapositive active
- Orienter la diapositive en mode Portrait/Paysage selon le format de la photo
- Redimensionner l'image à la taille de la diapo en mode création (dépend de la définition de l'écran)
A ce niveau l'image conserve ses caractéristiques d'origine
- Lancer le diaporama sur l'image -> l'affiche en plein écran
- Réaliser la copie d'écran
- Arrêter le diaporama
- Dans Excel, coller la copie dans la feuille de calculs (sert à connaître ses dimensions)
- Nommer l'image (NouveauChemin + Nom d'origine)
- Insérer un graphe aux dimensions de l'image et y coller l'image
- Noircir la zone de graphique et sa bordure (afin de la rendre invisible)
- Dans PowerPoint, supprimer la diapositive
- Supprimer la feuille de calculs dans Excel
Fin de la boucle -> Passage à l'image suivante
- Fermer Excel sans enregistrer
- Fermer PowerPoint sans enregistrer

Fonction InstrRev97() :
Développé sous PowerPoint 97, La fonction InstrRev97 remplace la fonction du même nom des versions ultérieures
Me facilite la récupérération du nom de fichier.

Fonction Lister() :
Dans cette fonction, la déclaration de fs en variant m'évite de valider la référence "Microsoft scripting runtime" dans l'éditeur VBA. Si cela pose un pb, la valider.

Sub Redimensionnement() :
Adapter les lignes de cette procédure à la taille de la diapo en mode création (dépend ici aussi de la définition de l'écran)

Exécution :
Adapter 'Chemin' et 'NewPath' dans la procédure "Appel()" et l'exécuter.

Le code :

Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Public XlApp
Public XlCL1
Public XLFL1
Public nb As Integer

Sub Appel()
Dim Chemin As String, NewPath As String
    Set XlApp = Excel.Application
    Set XlCL1 = XlApp.Workbooks.Add
    XlApp.Visible = False
    XlApp.DisplayAlerts = False
    XlApp.ScreenUpdating = False
    Chemin = "D:\Album photos\2002-2005 - Verlaine" 'Chemin des fichiers à ouvrir
    NewPath = "D:\VERLEINE\"                       'chemin des copies réduites
    On Error Resume Next
    ChDir NewPath
    If Err <> 0 Then
        MsgBox "Créer le répertoire " & NewPath & " avant d'exécuter ce programme", 0, ""
        Exit Sub
    End If
    On Error GoTo 0
    
    Lister Chemin, NewPath
    
    XlCL1.Close False
    XlApp.Quit
    Set XLFL1 = Nothing
    Set XlCL1 = Nothing
    Set XlApp = Nothing
 
End Sub

Public Function Lister(Chemin As String, NewPath As String)
Dim fs, Rep As Variant, NewRep As String, NomFich As String, Envers As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Lister = fs.GetFolder(Chemin).Files.Count
    NomFich = Dir(Chemin & "\*.jpg")
    Do While NomFich <> ""
        CopieEcran_En_jpg NewPath, Chemin & "\", NomFich
        NomFich = Dir()
    Loop
    'Pour chaque sous-répertoire, appel récursif de Lister
    For Each Rep In fs.GetFolder(Chemin).SubFolders
        Envers = InstrRev97(Rep.Path)
        NewPath = "D:\VERLEINE\" & Right(Rep.Path, InStr(Envers, "\") - 1) & "\"
        On Error Resume Next
        MkDir NewPath
        On Error GoTo 0
        NewRep = Lister(Rep.Path, NewPath)
    Next Rep
End Function

Function InstrRev97(Envers As String) As String
Dim i As Integer
    For i = Len(Envers) To 1 Step -1
        InstrRev97 = InstrRev97 & Mid(Envers, i, 1)
    Next
End Function

'Valider Microsoft Excel 10.0 Object library
Sub CopieEcran_En_jpg(NewPath As String, Chemin As String, NomFich As String)
Dim Limage As String
Dim Shp
    DoEvents
    Set XLFL1 = XlCL1.Sheets.Add
    ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=Chemin & NomFich, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=-1091, Top:=-701).Select
    DoEvents
    
    Redimensionnement 'procédure tenant compte du mode de l'image (Portrait/Paysage)
    
    'Lance la présentation
    ActivePresentation.SlideShowSettings.Run
    
    'Copie d'écran
    keybd_event vbKeySnapshot, 1, 0&, 0&
    DoEvents
    
    'Interrompt la présentation dans PowerPoint
    SlideShowWindows(Index:=1).View.Exit
    
    'Dans EXCEL
        'Collage de l'image afin d'en connaître la dimension
        XLFL1.Paste
        DoEvents
        
        Set Shp = XLFL1.Shapes(XLFL1.Shapes.Count)
        
        Limage = NewPath & NomFich
        Dim Gr
        With XLFL1.ChartObjects.Add(0, 0, Shp.Width, Shp.Height).Chart
            Set Gr = XLFL1.Shapes(XLFL1.Shapes.Count)
            .Paste
            DoEvents
            With XLFL1.ChartObjects(1).Border
                .ColorIndex = 1
                .Weight = 1
                .LineStyle = 1
            End With
            With XLFL1.ChartObjects(1).Interior
                .ColorIndex = 1
                .PatternColorIndex = 2
                .Pattern = 1
            End With
            DoEvents
            .Export Limage, "JPG"
            DoEvents
            Set Gr = Nothing
        End With
        ActivePresentation.Slides(1).Shapes(1).Delete
        DoEvents
        XLFL1.Delete
 
End Sub

Sub Redimensionnement()
    If ActiveWindow.Selection.ShapeRange.Height > ActiveWindow.Selection.ShapeRange.Width Then
        ActiveWindow.Selection.Cut
        With ActivePresentation.PageSetup
            .SlideOrientation = msoOrientationVertical
        End With
        DoEvents
        ActiveWindow.View.Paste
        With ActiveWindow.Selection.ShapeRange
            .Height = 720#
            .Width = .Width * .Height / 720#
            .Left = 0#
            .Top = 0#
        End With
      Else
        ActiveWindow.Selection.Cut
        With ActivePresentation.PageSetup
            .SlideOrientation = msoOrientationHorizontal
        End With
        DoEvents
        ActiveWindow.View.Paste
        With ActiveWindow.Selection.ShapeRange
            .Height = .Height * 720# / .Width
            .Width = 720#
            .Left = 0#
            .Top = 0#
        End With
    End If
End Sub

Gain de place :
Avant réduction : 6,88 Go (7 398 482 266 octets)
Après réduction : 258 Mo (271 285 708 octets)

Temps d'exécution :
Environ une heure pour 1869 images dans une vingtaine de dossiers (juste le temps de prendre un apéritif et un déjeuner frugal...)

En insertion dans un document Word ou un classeur Excel, en diaporama ou en utilisant l'Aperçu de Windows, les photos réduites sont aussi nettes à l'écran que les originales (A ne pas utiliser pour une projection sur grand écran)

[ouskel'n'or]

Pour ceux qui souhaitent que le répertoire "miroir" "parent" soit créé automatiquement, dans la procédure Appel(), remplacer les lignes

....On Error Resume Next
....ChDir NewPath
....If Err <> 0 Then
........MsgBox "Créer le répertoire " & NewPath & " avant d'exécuter ce programme", 0, ""
........Exit Sub
....End If
....On Error GoTo 0

par

    On Error Resume Next
        ChDir NewPath
        If Err <> 0 Then
            CreationRep NewPath
        End If
    On Error GoTo 0

et ajouter la procédure suivante

Sub CreationRep(rep)
Dim tablo, temp As String, i As Integer
    tablo = Split(rep, "\")
    ChDrive (Left(tablo(0), 1))
    temp = tablo(0) & "\"
    On error resume next
    For i = 1 To UBound(tablo) - 1
        temp = temp & tablo(i)
        If Dir(temp & "\") = "" Then
            MkDir temp
        End If
        temp = temp & "\"
    Next
    On error goto 0
End Sub

Pour ceux qui sont encore sur Office 97 ou qui préfère PowerPoint 97 aux versions ultérieures, et qui n'ont donc pas Split, dans la procédure CreationRep remplacer cette ligne

tablo = Split(rep, "\")

par la suivante

    tablo = Split97(rep, "\")

et ajouter cette fonction

Function Split97(LeString as string, separateur as string)
Dim Temp As String, LeTablo()
    Temp = LeString
    Do
        i = i + 1
        ReDim Preserve LeTablo(i)
        If InStr(Temp, separateur) <> 0 Then
                LeTablo(i) = Left(Temp, InStr(Temp, separateur) - 1)
                Temp = Right(Temp, Len(Temp) - InStr(Temp, separateur))
            Else
                LeTablo(i) = Temp
        End If
    Loop While InStr(Temp, separateur) <> 0
    Splitt = LeTablo
End Function

Ex du résultat obtenu après réduction :
(Mince ! Ma basket est percée, va falloir que j'en change ).............................................................▲

Taille avant réduction : 4 Mo 57
Taille après réduction : 272 ko