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

[aurelio.ewane]

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

 

[crocrocro]

Bonjour Aurelio,

jai plusieurs photos dans un dossier

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).

 

[crocrocro]

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

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

 

[patricktoulon]

Bonjour

tronquer une image

Bonjour à tous on utilise tous aujourd'hui des userform des images dans nos applicatif excel il arrive que l'on voudrait des images mais seulement une partie on utilise alors divers logiciel ainsi que paint etc....on découpe et on a...

excel-downloads.com

 

[patricktoulon]

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

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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

 

[patricktoulon]

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é

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'
'                 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

 

[crocrocro]

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

 

[patricktoulon]

CROPLEFT
CROPRIGHT
CROPTOP
CROPBOTTOM
et c'est tout tu fait ce que tu veux avec
prend le temps de recharger ma resource et balade toi avec les carés ou même la selection complète

 

[crocrocro]

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

 

[patricktoulon]

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

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

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

https://www.cjoint.com/c/NDsuCCJKW74

 

[crocrocro]

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.

 

[patricktoulon]

re
Bonjour @crocrocro
tu a télécharger mes exemple d app crop ?

 

[patricktoulon]

perso j'utilise gimp
c'est un truc de malade
je fait des truc de fous avec

 

[crocrocro]

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.

 

[patricktoulon]

re
moi aussi j'ai enregistré quelque macro dans GIMP
car on peut le faire
il est époustouflant ce truc
un peu lourd car c'est des couches et surcouches mais bon ça dépote sec