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