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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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
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
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
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
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
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.
 
Dernière édition:
Vote positif 0 Vote négatif
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: 8
  • Image 1.jpg_droite.jpg
    Image 1.jpg_droite.jpg
    3.6 KB · Affichages: 9
  • Image 1.jpg_gauche.jpg
    Image 1.jpg_gauche.jpg
    3.6 KB · Affichages: 9
Vote positif 0 Vote négatif
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
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
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Question Question
XL 2016 Modifier une photo externe en VBA
Réponses
1
Affichages
386
crocrocro
C
P
  • Question Question
XL 2016 texte d'images vers excel
Réponses
14
Affichages
168
jurassic pork
jurassic pork
BenHarber
  • Question Question
Microsoft 365 VBA : fonction qui calcule une durée entre 2 dates en années, mois et jours
Réponses
8
Affichages
115
BenHarber
BenHarber
J
  • Question Question
Microsoft 365 Excel exporter en Image JPG
Réponses
4
Affichages
646
patricktoulon
patricktoulon
jeff1494
  • Question Question
XL 2021 Orientation d'une image dans le commentaire d'une cellule
2 3
Réponses
42
Affichages
2 K
AtTheOne
AtTheOne
C
  • Question Question
Microsoft 365 Intégrer une image au milieu d'un mail créé via Excel VBA
Réponses
14
Affichages
580
patricktoulon
patricktoulon
T
  • Résolu(e)
Microsoft 365 Insérer une image DANS une cellule
Réponses
12
Affichages
813
Thomi
T
J
  • Question Question
Microsoft 365 Enregistrer une image dans un dossier
Réponses
5
Affichages
696
job75
job75
A
  • Question Question
XL 2021 Automatiser la génération de documents Word à partir d’Excel avec VBA
Réponses
12
Affichages
268
ali591
A
jeff1494
  • Résolu(e)
XL 2021 Extraction images depuis commentaire de cellule vers dossier.
11 12 13
Réponses
182
Affichages
2 K
patricktoulon
patricktoulon
Wayat
  • Question Question
XL 2019 Date et mise en forme conditionnelle
Réponses
5
Affichages
657
fanfan38
fanfan38
J
  • Résolu(e)
XL pour MAC Addition de timecode
Réponses
9
Affichages
370
mapomme
mapomme
patricktoulon
astuce pour loader un png dans un activx image dans un userform sans api
Réponses
2
Affichages
461
patricktoulon
patricktoulon
A
  • Question Question
Microsoft 365 Macro pour recherche de cellules entre 2 fichiers Excel
Réponses
6
Affichages
78
wDog66
wDog66
T
  • Question Question
Microsoft 365 Insérer une image à fond transparent à format png dans un Userform
2
Réponses
18
Affichages
3 K
patricktoulon
patricktoulon
N
  • Résolu(e)
Microsoft 365 Ecrire une formule de calcul en Vba Excel
24 25 26
Réponses
385
Affichages
11 K
TooFatBoy
TooFatBoy
L
  • Question Question
Microsoft 365 Insérer une plage Excel en image sous VBA pour envoi mail auto
Réponses
1
Affichages
382
fanch55
fanch55
BenHarber
  • Question Question
Microsoft 365 usf : insérer une images qui fait office de bouton
Réponses
2
Affichages
345
BenHarber
BenHarber
P
  • Résolu(e)
XL 2013 Boucle en VBA
Réponses
7
Affichages
398
PAT83500
P
D
  • Question Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
709
crocrocro
C
Retour