Macro pour creer et enregistrer un repertoire

[WITER]

Bonjour à tous, voila j'ai cette macro qui me permet grace à un bouton d'enregistrer une photo de ma feuille en lui donnant le non des cellules
C5 & "Photo" & A201.

Je voudrait la modifier pour qu'elle me creer un repertoir dans CHOTO/Mes images et quelle donne comme nom de repertoire le contenu de la cellule
C5
et comme nom pour la photo la compilation de
C5 & "Photo" & A201

merci d'avance pour votre aide


Sub ExportPhoto()

Dim Chemin As Variant
Chemin = Application.GetSaveAsFilename(InitialFileName:=Range("C5") & " Photo " & Range("A201"), FileFilter:="Fichiers Image GIF (*.gif), *.gif")
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
With Range("B4:L30")
'Code basé sur une procédure de gael charlery
.CopyPicture xlScreen, xlPicture
With ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height)
With .Chart
.ChartArea.Border.LineStyle = 0
.Paste
.Export Filename:=Chemin, FilterName:="GIF"
End With
.Delete
End With
End With
Application.ScreenUpdating = True

MsgBox " La photo à été enregistrée ! " '

End Sub

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Bonjour,

En t'inspirant de ce code que j'ai fourni il y a peu sur ce forum :

Sub test()
[COLOR=Black]'***Enregistrer une image d'un fichier Excel vers le disque dur[/COLOR]
Dim Img As Object
Dim ch As ChartObject
Dim FichNom as string

FichNom = Range("C5").Value & "Photo" & Range("A201").Value

Set Img = ActiveSheet.Shapes("Picture 1")
Img.Copy
'***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
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
ch.Chart.Export "C:PHOTO/Mes images\" & "FichNom" & ".jpeg", FilterName:="JPEG"
ch.Delete
End Sub

Cordialement

 

[Pierrot93]

Re : Macro pour creer et enregistrer un repertoire

Bonjour Witer, Spitnolan

Si j'ai bien compris, le code ci dessous pour créer un répertoire et exporter le graph à l'intérieur :

'pour créer un sous dossier dans un dossier nommé "DOSSIERS"
MkDir "C:\DOSSIERS\" & Range("C5").Value

With .Chart
.ChartArea.Border.LineStyle = 0
.Paste
.Export "C:\DOSSIERS\" & Range("C5").Value & "\photo " & Range("A201").Value & ".gif", "GIF"
End With

bon après midi
@+

Edition : A intercaler dans ton code

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,
Re Pierrot ,

Effectivement j'ai zappé cette partie répertoire car dans les explications de WITER le répertoire apparait plutôt comme un nom de fichier...

Cordialement

 

[WITER]

Re : Macro pour creer et enregistrer un repertoire

merci , pour vos code, mais je n 'arrive pas à les adapter à ma macro

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,

Que n'arrives tu pas à adapter ?
Si tu ne donnes pas d'explications, dur, dur...

Cordialement

 

[WITER]

Re : Macro pour creer et enregistrer un repertoire

Dans ma macro j'exporte l'image contenu des cellules B4:L30 avec comme nom le contenu de la cellule C5 le texte "Photo" et la cellule A201

Comment rajouter tous ca à la macro que tu ma donné ?

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,

et comme ca :

Sub test()
'***Enregistrer une image d'un fichier Excel vers le disque dur
Dim Img As Object
Dim ch As ChartObject
Dim FichNom as string

FichNom = Range("C5").Value & "Photo" & Range("A201").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
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
ch.Chart.Export "C:PHOTO\Mes images\" & "FichNom" & ".jpeg", FilterName:="JPEG"
ch.Delete
End Sub

Cordialement

 

[WITER]

Re : Macro pour creer et enregistrer un repertoire

C'est presque bon, la macro me créer bien la photo dans
CHOTO\Mes images\

photo
CHOTO\Mes images\FichNom.jpeg


mais en faite (si dans C5 j'ai le texte "PARIS" et dans A201 le texte "1") , elle devrait me créer dans
CHOTO\Mes images\
le repertoire
CHOTO\Mes images\PARIS\
puis m'enregistrer dedan la photo
CHOTO\Mes images\PARIS\PARISFichNom1.jpeg

merci une fois de plus pour ton aide

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,

il fallait préciser que tu étais débutant...

 Sub test()
'***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("A201").Value
Chemin = "C:PHOTO\Mes images\" & 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
MkDir Chemin
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
ch.Chart.Export Chemin & FichNom & ".jpeg", FilterName:="JPEG"
ch.Delete
End Sub

Mais rectifié sans filet et sans tester...

Cordialement

 

[WITER]

Re : Macro pour creer et enregistrer un repertoire

Effectivement j'aurais du preciser, lollll
par contre sans trop abuser de tes connaissances VBA,

serait t'il possible d'ajouter une variante au code

si le repertoire créer (texte cellule "C5" ) existe deja dans CHOTO\Mes images\,
il faudrait que la macro ne le créer pas
une 2 eme fois mais enregistre simplement la nouvelle photo dedans


merci une fois de plus

 

[Pierrot93]

Re : Macro pour creer et enregistrer un repertoire

Re

en l'absence de Spitnolan :

Sub ExportPhoto()
Sub test()
'***Enregistrer une image d'un fichier Excel vers le disque dur
Dim Img As Object, ch As ChartObject
Dim FichNom As String, Chemin As String
FichNom = Range("C5").Value & "Photo" & Range("A201").Value
Chemin = "C:\PHOTO\Mes images\" & 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
[B][COLOR="Red"]If Dir(Chemin) = "" Then MkDir Chemin[/COLOR][/B]
'***Enregistre le graphique sous un format image (JPEG, GIF, ...)
ch.Chart.Export Chemin & FichNom & ".jpeg", FilterName:="JPEG"
ch.Delete
End Sub

@+

Edition : manquait un "\" dans le chamin

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,

Remplace

'***pour créer un sous dossier dans un dossier nommé C5.value
MkDir Chemin

par

'***Vérifie si le sous répertoire existe et le crée sinon
If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin

Cordialement

Edit : Désolé Pierrot, pas rafraichi...
Presque la même chose
Mais je ne suis pas sûr que ta version fonctionne sans le vbdirectory

 

[Pierrot93]

Re : Macro pour creer et enregistrer un repertoire

Re

aarf, tu as raison Spitnolan, bien sur il faut bien l'attribut "vbDirectory", heureusement que tu es là pour rectifier mon horreur... bonne soirée
@+

 

[Spitnolan08]

Re : Macro pour creer et enregistrer un repertoire

Re,

pour rectifier mon horreur...

Si la flagellation te fait du bien...
mais bon, ce n'est pas bien grave à côté de tous tes très bons codes...
Maintenant, si tu veux on peut aussi te lapider
ou te pendre en place de Grèves

@+