XL 2016 Diviser une image .PNG en 2 en VBA excel

A

aurelio.ewane

XLDnaute Occasionnel
Bonjour les excelistes, jai plusieurs photos dans un dossier, je ne sais pas s'il est pôssible de les rogner ou de les decouper afin d'obtenir 2 images. c'est à dire de diviser ces 2 images en 2 dans le sens de la longeur.

j'en ai plusieurs et jai penser que ce serait faisable de créer une macro pour le faire....
 
Trier par date Trier par votes
C

crocrocro

XLDnaute Occasionnel
Bonjour Aurelio,
jai plusieurs photos dans un dossier
Cliquez pour agrandir...
Si moins d'une centaine, je ne vois pas trop l'intérêt de passer par Excel, qui sait faire (pas tout seul) beaucoup de choses, mais ne me parait pas l'outil le plus adapté.
Il existe de nombreux logiciels photos gratuits, faciles à prendre en main qui permettent ce genre de manip en quelques secondes (par photo).
 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
le code vba qui, pour une image, découpe en 2 images gauche et droite.
L'image source et les 2 images résultats sont dans le répertoire du classeur de la macro
VB: 
Sub RognerGaucheDroite()
Dim NomShape As String
Dim NomImage As String
Dim NomImageGauche As String
Dim NomImageDroite As String
Dim Largeur
Dim Hauteur
Const Ratio = 0.5

    NomImage = ThisWorkbook.Path & "\Crop Image.JPG"
    ActiveSheet.Pictures.Insert(NomImage).Select
    NomShape = Selection.Name
    Largeur = Selection.ShapeRange.Width
    Hauteur = Selection.ShapeRange.Height
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.ScaleWidth Ratio, msoFalse, msoScaleFromTopLeft
    ' partie gauche
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = Largeur
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = Hauteur
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = Largeur / 4
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
    Selection.CopyPicture
    ActiveSheet.Paste
    Selection.Name = "TempoG"
    With ActiveSheet
        Set MonChart = .ChartObjects.Add(0, 0, Selection.Width, Selection.Height)
        MonChart.Chart.ChartArea.Select
        MonChart.Chart.Paste
        NomImageGauche = ThisWorkbook.Path & "\Crop Image Gauche.JPG"
        MonChart.Chart.Export Filename:=NomImageGauche
        MonChart.Delete
    End With
    ' partie droite
    ActiveSheet.Shapes(NomShape).Select
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = -(Largeur / 4)
    Selection.CopyPicture
    ActiveSheet.Paste
    Selection.Name = "TempoD"
    With ActiveSheet
        Set MonChart = .ChartObjects.Add(0, 0, Selection.Width, Selection.Height)
        MonChart.Chart.ChartArea.Select
        MonChart.Chart.Paste
        NomImageDroite = ThisWorkbook.Path & "\Crop Image Droite.JPG"
        MonChart.Chart.Export Filename:=NomImageDroite
        MonChart.Delete
    End With
    '
    ActiveSheet.Shapes(NomShape).Delete
    ActiveSheet.Shapes("TempoG").Delete
    ActiveSheet.Shapes("TempoD").Delete

End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
un peu lourd comme code @crocrocro
il y a cropleft et cropright(TOUT SIMPLEMENT )
exemple inspiré de mon decoupeur d'image dans les ressource
tu choisi l'image dans le dialogue et ca te fait les deux image
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'fonction de decoupage
'code inspiré du cropseur d'image
'https://excel-downloads.com/resources/tronquer-une-image.1407/
'**********************************************************************************
Sub choppeImage()
    Dim fichier, destination$
    destination = Environ("userprofile") & "\DeskTop\"
    fichier = Application.GetOpenFilename("Pictures Files (*.jpg), *.jpg", 1, "ouvrir un fichier")
    If fichier = False Then Exit Sub
    decoupe fichier, destination
End Sub

Sub decoupe(fichierimage, DetinationFolder$)
    Dim w As Single, h As Single, shap As Shape, Side&, Nom$
    Nom = Mid(fichierimage, InStrRev(fichierimage, "\") + 1)
    With ActiveSheet
        Set shap = .Shapes.AddPicture(fichierimage, False, True, 0, 0, -1, -1)    'insère l'image a sa taille d'origine
        DoEvents
        With shap
            w = .Width: h = .Height
            For Side = 0 To 1
                .PictureFormat.CropLeft = w * IIf(Side = 0, 0.5, 0)
                .PictureFormat.CropRight = w * IIf(Side = 0, 0, 0.5)
                .CopyPicture
                With .Parent.ChartObjects.Add(shap.Left, shap.Top, shap.Width, shap.Height)
                    .ShapeRange.Line.Visible = msoFalse
                    Do While .Chart.Pictures.Count = 0: .Chart.Paste: Loop
                    .Chart.Export Filename:=DetinationFolder$ & Nom & "_" & IIf(Side = 0, "droite", "gauche") & ".jpg"
                    .Delete
                End With
            Next
            shap.Delete
        End With
    End With
End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
et si on veux aller jusqu'au bout
on inclu le png , jpg , gif
et cerise sur le gateau on garde la transparence
toujours avec le graphique exporté ;)
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'
'                 Fonction de decoupage moitié moitié en largeur

'code inspiré du cropseur d'image de patricktoulon
'https://excel-downloads.com/resources/tronquer-une-image.1407/

'pour le png avec transparence code inspiré de de la fonction dans les ressources de patricktoulon
'https://excel-downloads.com/resources/une-fonction-pour-capturer-un-object-dans-une-feuille-en-png-avec-un-graphique-qui-marche-vraiment.1469/

'**********************************************************************************
Sub choppeImage()
    Dim fichier, destination$

    destination = Environ("userprofile") & "\DeskTop\"

    fichier = Application.GetOpenFilename("Pictures Files (*.jpg;*.png;*.gif), *.jpg;*.png;*.gif", 1, "ouvrir un fichier")

    If fichier = False Then Exit Sub

    decoupe fichier, destination

End Sub
Sub decoupe(fichierimage, DetinationFolder$)
    Dim w As Single, h As Single, shap As Shape, Side&, Nom$, Ext$
    Nom = Mid(fichierimage, InStrRev(fichierimage, "\") + 1)
    Ext = Right(LCase(fichierimage), 3)
    With ActiveSheet
        Set shap = .Shapes.AddPicture(fichierimage, False, True, 0, 0, -1, -1)    'insère l'image a sa taille d'origine
        DoEvents
        With shap
            w = .Width: h = .Height
            For Side = 0 To 1
                .PictureFormat.CropLeft = w * IIf(Side = 0, 0.5, 0)
                .PictureFormat.CropRight = w * IIf(Side = 0, 0, 0.5)
                .CopyPicture
                With .Parent.ChartObjects.Add(shap.Left, shap.Top, shap.Width, shap.Height)
                    .ShapeRange.Line.Visible = msoFalse
                    Do While .Chart.Pictures.Count = 0: .Chart.Paste: Loop
                    If Ext = "png" Or Ext = "gif" Then
                        .Chart.ChartArea.Fill.Visible = msoTrue
                        .Chart.ChartArea.Fill.Solid
                        .Chart.ChartArea.Format.Fill.Transparency = 1
                    End If
                    .Chart.Export Filename:=DetinationFolder$ & Nom & "_" & IIf(Side = 0, "droite", "gauche") & "." & Ext
                    .Delete
                End With
            Next
            shap.Delete
        End With
    End With
End Sub
 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
Bonjour à tous,
pour Patrick :
effectivement, ton code pour ce cas particulier (c'est celui demandé) fonctionne parfaitement, avec en cadeau la transparence :)
j'avais poursuivi avec un découpage multiple de la photo originale à la fois horizontalement et verticalement.
Je me suis aperçu qu'en passant par un chart, comme tu le fais aussi, dans la photo résultat, on a systématiquement un liseré gris d'1 ou 2 pixels à droite en en bas :mad:
problème connu : https://excel-downloads.com/threads/sauvegarder-une-image-en-jpg.127898/
avec la solution de contournement (beaucoup de code, mais efficace de Kiki29 👍) qui passe par le presse-papier.
 
Dernière édition:
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
c'est bien ce que j'ai fait, crop, crop, crop... dans mon code et également testé avec ton code.
voir ci-dessous image originale, et crop gauche et droite avec un liseré blanc d'1 pixel obtenues avec ton code
 

Pièces jointes

  • Image 1.jpg
    Image 1.jpg
    4.6 KB · Affichages: 3
  • Image 1.jpg_droite.jpg
    Image 1.jpg_droite.jpg
    3.6 KB · Affichages: 3
  • Image 1.jpg_gauche.jpg
    Image 1.jpg_gauche.jpg
    3.6 KB · Affichages: 3
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
tu veux pas avoir ce liseré
passe par wiaut.dll la librairie WIA

inspiré de mon userform crops de 2014
c'est kado

VB: 
Sub Test1()
    Dim fichier
    fichier = Application.GetOpenFilename("image Files (*.jpg;*.bipmap;*.gif), *.jpg;*.bipmap;*.gif", 1, "ouvrir un fichier")
    If fichier = False Then Exit Sub
     decoupeImG CStr(fichier), 0
    decoupeImG CStr(fichier), 1
End Sub
'fonction de decoupage
Sub decoupeImG(fichier$, coté&)
    Dim fname As Variant, ext$, Img As Object, IP As Object
    ext = right(fichier, 3)
    Set Img = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")

    Img.LoadFile fichier
    IP.Filters.Add IP.FilterInfos("Crop").FilterID
    IP.Filters(1).Properties("Left") = Img.width * IIf(coté = 0, 0.5, 0)
    IP.Filters(1).Properties("Right") = Img.width * IIf(coté = 0, 0, 0.5)

    'au cas ou tu voudrais faire les 4
    'IP.Filters(1).Properties("Bottom") = Img.height * quelque chose
    'IP.Filters(1).Properties("Top") = Img.height * (Val(crtop.Value) / 100)

    Set Img = IP.Apply(Img)

    chem = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path & "\image" & coté & "." & ext, _
                                         filefilter:="image Files (*." & ext & "), *." & ext, Title:="ENREGISTREMENT DE la portion de l'image")
    If Dir(chem) <> "" Then Kill chem
    Img.SaveFile chem    'Enregistre la portion d'image


End Sub

encore kado
et les deux méthodes dans un userform png exclu because userform mais je peux ajouter une tite macro pour pourvoir afficher le png dans les userform

 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
Comme très souvent, parfait !
Avec Excel, on peut obtenir un même résultat en 3 lignes ou en 100 !
Magique quand on trouve 3, frustrant quand on trouve en 100 et qu'on sait que çà doit pouvoir se faire en 3.
Merci Patrick.
Pour ce qui concerne la manipulation des photos, je passe par un logiciel dédié gratuit, qui est magique quand on le connait bien.
 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
idem
quand on maitrise, très puissant pour la retouche photos. On peut faire le parallèle avec Excel.
quand je pense au temps de l'argentique, des heures pour retoucher très peu de choses sur quelques photos en labo...
J'ai créé quelques scripts et scénarios, mais le langage est hélas plus rustique que le VBA.
Et non, pas téléchargé avec le lien que tu as donné plus haut.
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2016 Modifier une photo externe en VBA
Réponses
1
Affichages
124
crocrocro
C
J
  • Question
Microsoft 365 Excel exporter en Image JPG
Réponses
4
Affichages
264
patricktoulon
patricktoulon
L
  • Question
XL 2016 Liste déroulante d'image
2
Réponses
17
Affichages
689
littlebird2
L
T
  • Question
Microsoft 365 Insérer une image à fond transparent à format png dans un Userform
2
Réponses
18
Affichages
2 K
patricktoulon
patricktoulon
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
360
crocrocro
C
arpop
  • Question
Microsoft 365 Copier une image d'une feuille a une autre
Réponses
2
Affichages
432
AeroZZ
A
Tomasisco21
  • Question
Microsoft 365 Fichier automatisé VBA - Template Budget project
Réponses
5
Affichages
542
Tomasisco21
Tomasisco21
L
  • Question
Microsoft 365 Insérer une plage Excel en image sous VBA pour envoi mail auto
Réponses
1
Affichages
139
fanch55
fanch55
José Alain
  • Résolu(e)
Word Insérer plusieurs images en même temps.
Réponses
3
Affichages
249
Alanou
A
L
  • Question
Power BI Power BI/Power Query - Images url & automatisation de transformation de colonnes
Réponses
0
Affichages
837
Loops74
L

Membres actuellement en ligne

24 membres et 346 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 250
Messages
2 086 612
Membres
103 260
dernier inscrit
NHOURRA