Declare Function SHGetPathFromIDList& Lib "shell32.dll" ( _
ByRef pidl As Long, ByVal pszPath As String)
Declare Function SHGetSpecialFolderLocation& Lib "shell32.dll" ( _
ByVal hwnd As Long, ByVal csidl As Long, ByRef ppidl As ITEMIDLIST)
Const SUFFIXE As String = ".gif"
Const CSIDL_DESKTOP = &H0
Const CSIDL_PERSONAL = &H5
Type SHITEMID
cb As Long
abID As Byte
End Type
Type ITEMIDLIST
mkid As SHITEMID
End Type
Sub ExportZoneTableau()
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim NomImage$
Dim i&
Dim Chemin$
If TypeName(Selection) <> "Range" Then Exit Sub
Set R = Selection
If R.Rows.Count <> 7 Or R.Columns.Count <> 13 Then
MsgBox "Veuillez sélectionner une plage de 7 lignes (colonnes A:M)"
Exit Sub
End If
Application.ScreenUpdating = False
Set S1 = ActiveSheet
Set S2 = Sheets.Add
S1.Cells.Copy
S2.Cells.PasteSpecial Paste:=xlPasteFormats
S2.Range("1:3,5:6").Delete
R.Copy
S2.[a2].PasteSpecial Paste:=xlPasteAll
Set R = S1.Range("a4:m4")
R.Copy
S2.[a1].PasteSpecial Paste:=xlPasteAll
Set R = S2.[a1].CurrentRegion
R.CopyPicture
If S2.[b2] <> "" Then
NomImage$ = S2.[b2]
Else
NomImage$ = "imageExport"
End If
'--- Définir le BUREAU ou MES DOCUMENTS ---
'Chemin$ = PathSpecial(CSIDL_PERSONAL) & "\" 'Mes documents
Chemin$ = PathSpecial(CSIDL_DESKTOP) & "\" 'Bureau
'------------------------------------------
Do
i& = i& + 1
Loop Until Dir(Chemin$ & NomImage$ & i& & SUFFIXE) = ""
S2.ChartObjects.Add(0, 0, R.Width, R.Height).Chart.Paste
S2.ChartObjects(1).Chart.Export Chemin$ & NomImage$ & i& & SUFFIXE
Application.DisplayAlerts = False
S2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function PathSpecial(SpecialFolder As Long) As String
Dim Retour&
Dim A$
Dim IDL As ITEMIDLIST
Retour& = SHGetSpecialFolderLocation(0, SpecialFolder, IDL)
If Retour& = 0 Then
A$ = Space(512)
Retour& = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal A$)
PathSpecial = Left(A$, InStr(A$, vbNullChar) - 1)
End If
End Function