XL 2010 Suppression du cadre blanc à l'extraction d'image

[Pierre C.]

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 et essais sur les forums, 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

 

[Pierre C.]

Problème solutionné ne pas utiliser la fonction copypicture de la selection mais la méthode copy de la classe Shape