Exporter et renommer

[WITER]

Bonjour, je cherche une fois de plus à modifier cette macro
Elle me permet de créer sous Chotos\
un repertoire avec comme nom le contenue de "C5"
et d'enregistrer un fichier .jpeg, avec comme nom le contenue de "C5"& "Photo" & "A1".

En "A1" j'ai le chiffre "1"

Par exemple:
C5=Paris
A1=1
donc elle me créer:
Chotos\Paris\ParisPhoto1.jpeg

Je voudrais que la macro modifie l'enregistrement des photos,c est à dire que lorsque qu'elle enregistre dans le repertoire créer, si "ParisPhoto1.jpeg" existe déja elle renomme la nouvelle photo "ParisPhoto2.jpeg" et ainsi de suite.

Voici la macro
merci une fois de plus pour votre aide precieuse

Sub ExportPhoto()


'***Enregistrer une image d'un fichier Excel vers le disque dur
Dim Img As Object
Dim ch As ChartObject
Dim FichNom As String, Chemin As String

FichNom = Range("C5").Value & " Photo " & Range("A1").Value
Chemin = "Chotos\" & Range("C5").Value & "\"

Set Img = Range("B4:L30")
Img.CopyPicture xlScreen, xlPicture
'***crée un objet graphique
Set ch = ActiveSheet.ChartObjects.Add(0, 0, Img.Width, Img.Height)
ch.Border.LineStyle = 0
'***Colle l'image dans le graphique
ch.Chart.Paste
'***pour créer un sous dossier dans un dossier nommé C5.value
If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
ch.Chart.Export Chemin & FichNom & ".jpeg", FilterName:="jpeg"
ch.Delete
End Sub

 

[gilbert_RGI]

Re : Exporter et renommer

Bonsoir

cette modif permet d'aller jusqu' a 19 sauvegardes CàD "ParisPhoto19.jpeg" ensuite l'incrémentation n'est plus bonne mais cela suffit peut-être ?

Sub ExportPhoto()


'***Enregistrer une image d'un fichier Excel vers le disque dur
Dim Img As Object
Dim ch As ChartObject
Dim FichNom As String, Chemin As String

FichNom = Range("C5").Value & " Photo " & Range("A1").Value
Chemin = "C:\Photo\" & Range("C5").Value & "\"

Set Img = Range("B4:L30")
Img.CopyPicture xlScreen, xlPicture
'***crée un objet graphique
Set ch = ActiveSheet.ChartObjects.Add(0, 0, Img.Width, Img.Height)
ch.Border.LineStyle = 0
'***Colle l'image dans le graphique
ch.Chart.Paste
'***pour créer un sous dossier dans un dossier nommé C5.value
If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
plus:
If Trouve_Fich(Chemin & FichNom & ".jpeg") = True Then
num = num + 1
If num > 10 Then num = 1
FichNom = Left(FichNom, Len(FichNom) - 1) & num
GoTo plus
End If
ch.Chart.Export Chemin & FichNom & ".jpeg", FilterName:="jpeg"
ch.Delete
End Sub
Function Trouve_Fich(Fichier$) As Boolean
Trouve_Fich = Dir(Fichier) <> ""
End Function


Bonne soirée

RGI

 

[WITER]

Re : Exporter et renommer

Merci gilbert_RGI pour le code , mais il bug à partir de:


num = num + 1
If num > 10 Then num = 1
FichNom = Left(FichNom, Len(FichNom) - 1) & num
GoTo plus
End If
ch.Chart.Export Chemin & FichNom & ".jpeg", FilterName:="jpeg"
ch.Delete
End Sub
Function Trouve_Fich(Fichier$) As Boolean
Trouve_Fich = Dir(Fichier) <> ""
End Function

 

[gilbert_RGI]

Re : Exporter et renommer

Voilà une nouvelle version sans restriction de nombre

et chez moi ça ne bug pas

le code doit être dans un module standard et pas dans la feuille

le numero en A1 n'est pas utilisé

Sub ExportPhoto()


'***Enregistrer une image d'un fichier Excel vers le disque dur
Dim Img As Object
Dim ch As ChartObject
Dim FichNom As String, Chemin As String

FichNom = Range("C5").Value & " Photo "
Chemin = "C:\Photo\" & Range("C5").Value & "\"

Set Img = Range("B4:L30")
Img.CopyPicture xlScreen, xlPicture
'***crée un objet graphique
Set ch = ActiveSheet.ChartObjects.Add(0, 0, Img.Width, Img.Height)
ch.Border.LineStyle = 0
'***Colle l'image dans le graphique
ch.Chart.Paste
'***pour créer un sous dossier dans un dossier nommé C5.value
If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
num = 1
plus:
If Trouve_Fich(Chemin & FichNom & num & ".jpeg") = True Then
num = num + 1
GoTo plus
End If
ch.Chart.Export Chemin & FichNom & num & ".jpeg", FilterName:="jpeg"
ch.Delete
End Sub
Function Trouve_Fich(Fichier$) As Boolean
Trouve_Fich = Dir(Fichier) <> ""
End Function

salutations

RGI

 

[WITER]

Re : Exporter et renommer

merci,gilbert_RGI

cette macro la, fonctionne tres bien.

encore une fois merciiiiiiiiiiii