Sub ExportChart()
Dim sChartName$, sFileName$, sPathName$, sPrompt$, sCurDir$, iOverwrite&
If ActiveSheet Is Nothing Then GoTo ExitSub
If ActiveChart Is Nothing Then GoTo ExitSub
sCurDir = CurDir
sPathName = ActiveWorkbook.Path
If Len(sPathName) > 0 Then
ChDrive sPathName
ChDir sPathName
End If
sFileName = "ImageDuGraphique.png"
Do
sChartName = Application.GetSaveAsFilename(sFileName, "Fichier PNG ,*.png", , _
"Choisissez un dossier et saisir le nom l'image désiré")
If Len(sChartName) = 0 Then GoTo ExitSub
If sChartName = "False" Then GoTo ExitSub
sChartName = sChartName
If Not FileExists(sChartName) Then Exit Do
sFileName = FullNameToFileName(sChartName)
sPathName = FullNameToPath(sChartName)
sPrompt = "Un fichier nommé " & sFileName & " existe déj dans: " & sPathName
sPrompt = sPrompt & vbNewLine & vbNewLine & "Voulez-vous le remplacer par celui-ci?"
iOverwrite = MsgBox(sPrompt, vbYesNoCancel + vbQuestion, "Fichier déjà existant")
Select Case iOverwrite
Case vbYes
Exit Do
Case vbNo
' do nothing, loop again
Case vbCancel
GoTo ExitSub
End Select
Loop
ActiveChart.Export sChartName, "PNG"
ExitSub:
ChDrive sCurDir
ChDir sCurDir
End Sub
Function FileExists(ByVal FileSpec As String) As Boolean
' Karl Peterson MS VB MVP
Dim Attr As Long
' Guard against bad FileSpec by ignoring errors
' retrieving its attributes.
On Error Resume Next
Attr = GetAttr(FileSpec)
If Err.Number = 0 Then
' No error, so something was found.
' If Directory attribute set, then not a file.
FileExists = Not ((Attr And vbDirectory) = vbDirectory)
End If
End Function
Function FullNameToFileName(sFullName As String) As String
Dim k As Integer
Dim sTest As String
If InStr(1, sFullName, "[") > 0 Then
k = InStr(1, sFullName, "[")
sTest = Mid$(sFullName, k + 1, InStr(1, sFullName, "]") - k - 1)
Else
For k = Len(sFullName) To 1 Step -1
If Mid$(sFullName, k, 1) = "\" Then Exit For
Next k
sTest = Mid$(sFullName, k + 1, Len(sFullName) - k)
End If
FullNameToFileName = sTest
End Function
Function FullNameToPath(sFullName As String) As String
' does not include trailing backslash
Dim k As Integer
For k = Len(sFullName) To 1 Step -1
If Mid$(sFullName, k, 1) = "\" Then Exit For
Next k
If k < 1 Then
FullNameToPath = ""
Else
FullNameToPath = Mid$(sFullName, 1, k - 1)
End If
End Function