Suppression du cadre blanc à l'extraction d'image

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

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
12extractphotos.xlsm (901.17 Ko)

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 ?

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

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

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

Bonjour Pierre,

j'suis bien contente que tout fonctionne,

merci pour ce retour et bonne continuation, @+ isabelle

Rechercher des sujets similaires à "suppression cadre blanc extraction image"