Sub ExtractionImagesClasseur()
Dim Pict As Picture, Nb As Byte, F As Worksheet
Application.ScreenUpdating = False
For Each F In ThisWorkbook.Worksheets
For Each Pict In F.Pictures
Pict.CopyPicture 'copie l'image
With F.ChartObjects.Add(0, 0, Pict.Width, Pict.Height).Chart
.Paste 'colle l'image dans un graphique temporaire
'Sauvegarde au format image, dans le même répertoire que ce classeur. voir choix gif/jpg/bmp !?
'.Export ThisWorkbook.Path & "\" & Pict.Name & ".gif", "GIF"
'.Export ThisWorkbook.Path & "\" & Pict.Name & ".jpg", "JPG"
.Export ThisWorkbook.Path & "\" & Pict.Name & ".bmp", "BMP"
End With
'Supprime le graphique
Nb = F.ChartObjects.Count: F.ChartObjects(Nb).Delete
Next Pict: Next F
Application.ScreenUpdating = True
End Sub
Test OK sur XL 2013
Il y a deux paramètres à renseigner (le 3ième est optionnel car prédéfini dans xlsObj2HTM)
1) le nom de la feuille (voir exemples de syntaxe dans le code)
2) le nom du fichier *.htm qui sera généré lors de l'export
NB: Attention le nom du fichier *.htm ne doit pas dépasser 8 caractères
(à cause de cette ligne : ActiveWorkbook.WebOptions.UseLongFileNames = False)
Code vba:
Sub test()
xlsObj2HTM Feuil1, "BonDodo" 'code name
'xlsObj2HTM ActiveSheet, "BonDodo"
'xlsObj2HTM sheets("Feuil1"), "BonDodo" 'nom de la feuille
End Sub
Code vba:
Private Sub xlsObj2HTM(F As Worksheet, NomFic$, Optional XPath$ = "C:\Temp\ExportIMGS\")
ActiveWorkbook.WebOptions.UseLongFileNames = False
ActiveWorkbook.PublishObjects.Add(1, XPath & NomFic & ".htm", F.Name, "", 0).Publish (True)
End Sub
Sub Exporte_Shapes()
Dossier = "C:\Temp\"
For i = 1 To ActiveSheet.Shapes.Count
NomShape = ActiveSheet.Shapes(i).Name
ActiveSheet.Shapes(i).Copy
Sheets.Add
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
.Paste
.Export Dossier & NomShape & ".jpg", "JPG"
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Next
End Sub
Sub test()
Dim Sh As Shape, Ppt As Object, Pres As Object, ShPpt As Object
Set Ppt = CreateObject("Powerpoint.Application")
Set Pres = Ppt.presentations.Add
Pres.slides.Add 1, 12
For Each Sh In ActiveSheet.Shapes
If Sh.Type = msoPicture Then
Sh.Copy
Set ShPpt = Pres.slides(1).Shapes.Paste
ShPpt.Export "d:\temp\" & ShPpt.Name & ".png", 2
ShPpt.Delete
End If
Next
Pres.Saved = True
Pres.Close
Set Pres = Nothing
Ppt.Quit
Set Ppt = Nothing
End Sub
rebonjour,
merci pour la réponse ...
mais je voulais prendre que les photos, je pense que c'est impossible ...
cordialement
asma
For Each F In ThisWorkbook.Worksheets
For Each Pict In F.Pictures
If Lcase(Left(Pict.Name, 5)) = "photo" then
'ici la suite du code
end if
Next Pict: Next F
ok je vais essayer aussi pour voir, y a-t-il un lien pour apprendre à faire des macros, en tout cas je dois nommer chaque photo par le matricule des employés pour les injecter sur le logiciel, l'informaticien va faire des essais cet après-midi
coul ce forum