Suppression du cadre blanc à l'extraction d'image Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
P
Pierre_C
Nouveau venu
Nouveau venu
Messages : 3
Inscrit le : 23 octobre 2018
Version d'Excel : 2010 FR

Message par Pierre_C » 23 octobre 2018, 19:36

Bonjour,

Je souhaite extraire toutes les images d'un fichier excel et les enregistrer au format JPG.
Je réussi à extraire les images et les enregistrer avec le code ci-dessous :) mais malheureusement il me crée systématiquement un cadre blanc / bords blancs autour de la photo :bof:

Après de nombres recherches dans les forums et un post sur un autre forum, c'est sans succès.

Quelqu'un aurait il une idée pour supprimer ces bords ou une alternative pour ne pas utiliser la méthode copypicture (qui semble être la source du problème)?

Code et fichier ci-dessous.

Merci beaucoup de votre aide.




Sub Export_Image()
Dim oshape As Shape
Dim strImageName, strshortname, strDirPhotos As String
Dim oDia, oChartArea As Object
Dim origHeight, origWidth As Variant
Dim i As Integer

strDirPhotos = "c:\photos\" ' A modifier
  If Dir(strDirPhotos, vbDirectory) = "" Then MkDir strDirPhotos
On Error GoTo erreurTraitement
i = 0

For Each oshape In ActiveSheet.Shapes
Err.Number = 0
If oshape.Type = 13 Then
   i = i + 1
 
   strImageName = ActiveSheet.Cells(i, 1).Value
   
    
   origHeight = oshape.Height
   origWidth = oshape.Width
   oshape.Select
     
 '   Picture format initialization
    Selection.ShapeRange.PictureFormat.Contrast = 0.5
    Selection.ShapeRange.PictureFormat.Brightness = 0.5
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse:
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
    
    Selection.ShapeRange.Rotation = 0
    Selection.ShapeRange.PictureFormat.CropLeft = 0#
    Selection.ShapeRange.PictureFormat.CropRight = 0#
    Selection.ShapeRange.PictureFormat.CropTop = 0#
    Selection.ShapeRange.PictureFormat.CropBottom = 0#
    Selection.ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
   
    '/Picture format initialization
    
    Application.Selection.CopyPicture
       
    
    
    'Restaure la taille initiale après copie et avant coller
    Selection.ShapeRange.ScaleHeight (origHeight / oshape.Height), msoTrue, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth (origWidth / oshape.Width), msoTrue, msoScaleFromTopLeft

'créé l'objet Chart pour l'export
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oshape.Width, oshape.Height)
    oDia.Border.LineStyle = 0
    Set oChartArea = oDia.Chart
    
    
    With oChartArea
        .ChartArea.Select
        .Paste
        .Export (strDirPhotos & strImageName & ".jpg")
    End With
    oDia.Delete
    'oshapex.Delete
    'oChartArea.Delete
End If

erreurTraitement:
If Err.Number <> 0 Then MsgBox (Err.Description)
Next

If Err.Number = 0 Then MsgBox ("Export réussi sur " & strDirPhotos)
End Sub


ExtractPhotos.xlsm
(901.17 Kio) Téléchargé 5 fois
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 5'716
Appréciations reçues : 333
Inscrit le : 16 mars 2017
Version d'Excel : 2010

Message par i20100 » 23 octobre 2018, 20:34

Bonjour,

il faut enlever la ligne,
.ChartArea.Select
il y a aussi un peu de ménage à faire sur l'ensemble du code
avez-vous besoin d'aide à ce sujet ?
Vive ces nouvelles saisons qui nous colorent.
isabelle
P
Pierre_C
Nouveau venu
Nouveau venu
Messages : 3
Inscrit le : 23 octobre 2018
Version d'Excel : 2010 FR

Message par Pierre_C » 23 octobre 2018, 20:48

Bonjour SabV,

Merci de la réponse rapide.

J'ai retiré la ligne
.ChartArea.Select
et recompilé, cela ne fonctionne pas chez moi.

Avez-vous nettoyé autre chose?

Merci.

Pierre
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 5'716
Appréciations reçues : 333
Inscrit le : 16 mars 2017
Version d'Excel : 2010

Message par i20100 » 23 octobre 2018, 22:19

Bonjour Pierre,

voici la macro que j'utilise,
à tester,
Sub test()
Dim Sh As Shape, Chemin As String, Sht As Worksheet
Dim MaFeuil As Worksheet, NomImg As String, Pic As Object

Chemin = "C:\Users\isabelle\Documents\test\" 'à adapter

Application.ScreenUpdating = False
Set f = ActiveSheet
Set MaFeuil = Worksheets.Add

   For Each Sh In f.Shapes
       If TypeName(Sh.OLEFormat.Object) = "Picture" Then
       i = i + 1
           NomImg = Sh.Name & i
           Sh.Copy
           With MaFeuil
               With .ChartObjects
                   With .Add(Sh.Left, Sh.Top, _
                       Sh.Width, Sh.Height)
                   .Chart.Paste
                   .Chart.Export Chemin & f.Range("A" & i) & ".jpg", "jpg"
                   End With
               End With
           End With

       MaFeuil.Shapes(1).Delete
       End If
   Next

Application.DisplayAlerts = False
MaFeuil.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
j'ai épuré un peu plus
Vive ces nouvelles saisons qui nous colorent.
isabelle
P
Pierre_C
Nouveau venu
Nouveau venu
Messages : 3
Inscrit le : 23 octobre 2018
Version d'Excel : 2010 FR

Message par Pierre_C » 24 octobre 2018, 00:08

Bonsoir Isabelle,

Un grand merci pour votre réponse et d'avoir épuré un max.

Cela a finalement fonctionné. J'ai dû tout de même modifier le code et réinsérer le
 .ChartArea.select 
dans la boucle pour empêcher que cela bloque.Je pense que vous devez avoir une autre version que la mienne.

Voici le code final et fonctionnel. La grande différence (outre le nettoyage bien utile) est donc d'avoir utilisé la méthode Copy du Shape à la place de la méthode Copypicture appliquée à la Selection
Sub test()
Dim Sh As Shape, Chemin As String, Sht As Worksheet
Dim MaFeuil As Worksheet, NomImg As String, Pic As Object
Dim f As Worksheet
Dim i As Integer


Chemin = "C:\Photos\" 'à adapter

Application.ScreenUpdating = False
Set f = ActiveSheet
Set MaFeuil = Worksheets.Add

   For Each Sh In f.Shapes
       If TypeName(Sh.OLEFormat.Object) = "Picture" Then
       i = i + 1
           NomImg = Sh.Name & i
           Sh.Copy
           With MaFeuil
               With .ChartObjects
                   With .Add(Sh.Left, Sh.Top, Sh.Width, Sh.Height).Chart
                   .ChartArea.Select
                   .Paste
                   .Export Chemin & f.Range("A" & i) & ".jpg", "jpg"
                   End With
               End With
            End With
            
               
     
     Set Pic = f.Pictures.Insert(Chemin & f.Range("A" & i) & ".jpg")
       With Pic
           .Left = Sh.Left
           .Top = Sh.Top
           .Width = Sh.Width
           .Height = Sh.Height
       End With

       Pic.Name = NomImg
       MaFeuil.Shapes(1).Delete
       End If
   Next

Application.DisplayAlerts = False
MaFeuil.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Encore Merci :) :)
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 5'716
Appréciations reçues : 333
Inscrit le : 16 mars 2017
Version d'Excel : 2010

Message par i20100 » 24 octobre 2018, 05:27

Bonjour Pierre,

j'suis bien contente que tout fonctionne,
merci pour ce retour et bonne continuation, @+ isabelle
Vive ces nouvelles saisons qui nous colorent.
isabelle
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message