Discussion :

[Klode784]

Bonjour à tous du forum,

J'ai un classeur qui me permet de créer et d'enregistrer des commandes. Par défaut, une copie de la commande en PDF est enregistrée dans le répertoire où figure mon classeur excel. Ce que j'aimerais, si c'est possible c'est que la copie PDF soit enregistrée dans le répertoire correspondant à l'année de la date de départ. Si je crée une commande qui a pour date de départ l'année 2011 le PDF devrait s'enregistrer dans le répertoire 2011 et si c'est pour 2012, cela devrait s'enregistrer dans le répertoire 2012. Cela m'éviterait de manipuler les fichiers PDF entre les différents répertoires. Si on pouvait me donner quelques pistes pour y parvenir, cela m'aiderait. Voici la partie de mon code qui me permet de sauvegarder en PDF:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Private Sub Impression(ByVal Fichier As String)
With ThisWorkbook
    If MsgBox("Voulez-vous imprimer la commande?", vbYesNo) = vbNo Then Exit Sub
    'Ne pas imprimer
    ThisWorkbook.Sheets("Contrat").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Fichier & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Application.DisplayAlerts = True
End With
End Sub

Merci pour votre aide,

Claude

[kiki29]

Salut, pour la création d'un dossier, à adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
 
Private Function CreationDossier(sDossier As String) As Long
' Pour valeur retournée par CreationDossier
'   Voir http://msdn.microsoft.com/en-us/library/bb762131(VS.85).aspx
'   et   http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
    CreationDossier = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Sub Tst()
Dim y As String
    y = Year(Now)
    CreationDossier ThisWorkbook.Path & "\" & y
End Sub

[Klode784]

Bonjour et merci pour la réponse,

En fait le dossier est déjà créé, par exemple 2011, 2012. Si je crée une commande aujourd'hui pour un départ le 1 janvier 2012, je veux que la copie PDF soit sauvegardée automatiquement dans 2012. Par contre, si je crée une commande aujourd'hui pour un départ le 31 décembre 2011, je voudrais qu'elle soit sauvegardée dans le dossier 2011. Si c'est pour le 15 avril 2013, je veux qu'elle soit sauvegardée dans 2013, etc. La date de départ est insérée dans la cellule B18 de la nouvelle commande avec un calendrier sous forme yyyy-mm-dd.

Claude

[kiki29]

Salut, l'intérêt de CreationDossier c'est de créer, s'il n'existe pas, le dossier sinon il ne se passe rien ( voir lien sur site Microsoft pour valeur retournée )
autrement tu as sous les yeux tous les éléments pour l'adapter à ton contexte

En supposant que le CodeName de Contrat est Feuil1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Year(Feuil1.Range("B18"))

Pour ce qui est du CodeName et de son intérêt voir http://www.developpez.net/forums/d92...cel/vba-bases/

A lire également : http://didier-gonard.developpez.com/...-excel-et-vba/

[Klode784]

Bonjour, donc cela veut dire qu'avec ce code pour créer un dossier, je fais d'une pierre deux coups pour ainsi dire. Si le dossier nommé 2012 n'existe pas au moment de la création de la commande, il sera tout simplement créé et s'il existe, il ne se passera rien et enregistrera la commande dans le dossier prévu.

C'est parfait parce qu'en ce moment, je reçois encore des commandes pour cette année et l'année prochaine. Cela me posait un certain problème.

Maintenant, pour intégrer le tout dans VBA, est-ce que je dois tout simplement inclure le code dans la feuil1 ou si je dois créer un module.

Merci pour les liens,

Claude

[kiki29]

Dans un module standard qqch comme ceci , à adapter sans doute

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Private Function CreationDossier(Dossier As String) As Long
    CreationDossier = SHCreateDirectoryEx(0&, Dossier, 0&)
End Function
 
Private Sub Impression(Fichier As String, y As String)
Dim sDossier As String
 
    If MsgBox("Voulez-vous imprimer la commande?", vbYesNo) = vbNo Then Exit Sub
 
    sDossier = ThisWorkbook.Path & "\" & y
    With Feuil1
        .Activate
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Fichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        CreationDossier sDossier
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=sDossier & "\" & Fichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
End Sub
 
Sub Tst()
Dim y As String
Dim sFichier As String
    y = Year(Feuil1.Range("B18"))
    sFichier = "Essai.pdf"
    Impression sFichier, y
End Sub

[Klode784]

Bonjour à tous,

J'ai essayé d'intégrer le code fourni de différentes façons mais soit rien ne se passe, ou j'obtiens un message d'erreur (449 pour un argument optionel non-disponible). J'ai aussi essayé de l'intégrer dans un module standard sans succès. Il doit y avoir un conflit quelque part mais je ne suis pas assez expérimenté pour le trouver seul. Je dispose donc le code ici, si vous pouvez m'aider à trouver la solution à mon problème.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
 
Option Explicit
 
'---------------------------------------------------------------------------------------
' Procedure : Worksheet_SelectionChange
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet d'appeler Userform2 pour permettre d'entrer les dates en B18 et E18
'---------------------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If Not Application.Intersect(Target, Range("B18,E18")) Is Nothing Then UserForm2.Show
 
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Worksheet_Change
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet de récupérer les données de Liste et BDD dans contrat en fonction du N° de commande
'             Permet aussi de remplir spot time
'---------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, v As Range
Dim Client As String
Dim TbLst, TbCli
Dim i As Byte
 
TbLst = Array("E7", "B10", "B8", "B18", "E18", "E12", "B19", "E19", "B30", "A22", "A24", "E10", "A27", "D30", "E31", "C32", "C33", "C34", "E44", "B44")
TbCli = Array("B11", "B12", "B13", "B14", "B15", "B16")
 
If Target.Address(0, 0) = "E8" Then
    If Target.Value <> "" Then
        Set c = Sheets("Liste").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            LaLigne = c.Row
            Client = c.Offset(0, 2).Value
            MsgBox "La commande n°: " & Target.Value & " du client: " & Client & " existe déjà, OK pour modifier"
            For i = 0 To UBound(TbLst)
                Range(TbLst(i)).Value = Sheets("Liste").Cells(LaLigne, i + 2).Value
            Next i
            If Client <> "" Then
                Set v = Sheets("BDD Clients").Range("A:A").Find(Client, LookIn:=xlValues, lookat:=xlWhole)
                If Not v Is Nothing Then
                    For i = 0 To UBound(TbCli)
                        If i <> 6 Then
                            'If i <> 5 Then
                                Range(TbCli(i)).Value = Sheets("BDD Clients").Cells(v.Row, i + 2).Value
                            Else
                                Range(TbCli(i)).Value = Range(TbCli(i - 1)).Value & " " & Sheets("BDD Clients").Cells(v.Row, i + 2).Value
                            End If
                        'End If
                    Next i
                    Set v = Nothing
                End If
            End If
            Set c = Nothing
        End If
    End If
ElseIf Target.Address(0, 0) = "B19" Then
    Application.EnableEvents = False
    If Target.Value <> "" Then Range("E15").Value = DateAdd("n", -15, Target.Value)
    Application.EnableEvents = True
End If
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : RAZ
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet d'effacer les cellules de Contrat (Ces cellules sont nommés MAPLAGE)
'---------------------------------------------------------------------------------------
Private Sub RAZ()
Dim c As Range
Application.EnableEvents = True
 
Application.ScreenUpdating = False
With Sheets("Contrat")
    For Each c In .Range("MAPLAGE")
        If Not c.HasFormula Then c.MergeArea.ClearContents
    Next c
    .Range("D30").Value = 0
    .Range("E8").Select
End With
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : btnNEWCOM_Click
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet d'ajouter un nouveau n° de commande
'---------------------------------------------------------------------------------------
Private Sub btnNEWCOM_Click()
Dim LastLig As Long, NewCom As Long
 
If MsgBox("Voulez-vous ajouter une nouvelle commande?", vbYesNo) = vbYes Then
    'Vider la formulaire
    RAZ
    With Worksheets("Liste")
        'Dernière cellule remplie de colonne A feuille Liste
        LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
        'Incrémenter le n° de commande
        NewCom = Val(.Range("A" & LastLig).Value) + 1
    End With
    With Worksheets("Contrat")
        'ecriture dans la cellule E8 de "Contrat" du nouveau numero
        .Range("E8").Value = NewCom
        'ecriture de la date en B8...
        .Range("B8").Value = Date
    End With
    'message qui dit le dernier num de commande et le nouveau...
    MsgBox "Dernière commande : " & NewCom - 1 & vbCrLf & "Nouvelle commande : " & NewCom, vbInformation
End If
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : btnCLIENT_Click
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet d'ouvrir Userform1
'---------------------------------------------------------------------------------------
Private Sub btnCLIENT_Click()
 
UserForm1.Show
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Impression
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet l'impression du contrat en pdf
'---------------------------------------------------------------------------------------
Private Sub Impression(ByVal Fichier As String)
With ThisWorkbook
    If MsgBox("Voulez-vous imprimer la commande?", vbYesNo) = vbNo Then Exit Sub
    'Ne pas imprimer
    ThisWorkbook.Sheets("Contrat").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Fichier & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Application.DisplayAlerts = True
End With
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Mailing
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet la mailing
'---------------------------------------------------------------------------------------
Private Sub Mailing(ByVal FichierPDF As String)
' Attention, cocher la référence Microsoft Outlook XX.X Object Library
Dim OlApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim ol As New Outlook.Application
Dim olmail As MailItem
Dim CurrFile As String
If MsgBox("Voulez-vous envoyer la commande par courriel?", vbYesNo) = vbNo Then Exit Sub
' Ne pas envoyer la commande
Shell "C:\Program Files\Microsoft Office\Office12\OUTLOOK.EXE"
' Ouvrir Outlook préalablement
Set Rdv = OlApp.CreateItem(olAppointmentItem)
With Rdv
    .MeetingStatus = olNonMeeting
    .Importance = olImportanceNormal
    .Subject = Worksheets("Contrat").Range("E8").Text
    .Body = Worksheets("Contrat").Range("B10").Text & " --> " & Worksheets("Contrat").Range("A24").Text
    .Location = ""
    .Start = Format(Worksheets("Contrat").Range("B18"), "yyyy/mm/dd")
    .Duration = 30                                                   'minutes
    .Categories = ""
    .Display
End With
Set OlApp = Nothing
'envoyer fichier PDF par courriel et signature
Set ol = New Outlook.Application
Set olmail = ol.CreateItem(olMailItem)
With olmail
    .To = "cahoule@skyportinternational.com"        'adresse destinataire
    .Subject = "Nouvelle commande ou modification"  'ici le sujet
    .BodyFormat = olFormatHTML
    .HTMLBody = "Bonjour Carmenne, SVP préparer/modifier la commande ci-jointe.<br><br>" & GetBoiler("C:\Users\Claude Dorion\AppData\Roaming\Microsoft\Signatures\Skyport.htm")   'ici le corps du mail et signature
    .Attachments.Add ThisWorkbook.Path & "\" & FichierPDF & ".pdf"   'ici la pièce jointe
    .Display   '.Display /Send : Display correspond à l'affichage du message / Send demande un envoie direct
End With
End Sub
 
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : btnCREECOM_Click
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet la sauvegarde/ modification de la commande dans feuille Liste
'---------------------------------------------------------------------------------------
Private Sub btnCREECOM_Click()
Dim NomFichier As String, Num As String
Dim c As Range
Dim i As Byte
Dim TbLst
 
Application.ScreenUpdating = False
'***** test si ligne commande existe deja *****
With Worksheets("Liste")
    Num = Worksheets("Contrat").Range("E8").Value
    If Trim(Num) <> "" Then
        Set c = .Range("A:A").Find(Num, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            'SI LIGNE EXISTE DEJA, alors message d'alerte et sortie de la macro
            LaLigne = c.Row
            Set c = Nothing
            If MsgBox("La commande  " & Num & "  est déjà enregistrée. Voulez-vous la modifier?", vbYesNo + vbDefaultButton2 + vbExclamation) = vbNo Then Exit Sub
        Else
            '***** Initialisation de la ligne vers la quelle les donnees de la nvelle commande seront ecrites *****
            LaLigne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End If
        '***** Creation du fichier *****
        'creation du futur nom du fichier = "nom client" + " - " + "numero de commande"
        With Worksheets("Contrat")
            NomFichier = .Range("E8").Text & " - " & .Range("B10").Text
        End With
        ''*****Sauvegarde
        Impression NomFichier
        ''*****Mailing
        Mailing NomFichier
        '***** Mise a jour de la Liste *****
        TbLst = Array("E8", "E7", "B10", "B8", "B18", "E18", "E12", "B19", "E19", "B30", "A22", "A24", "E10", "A27", "D30", "E31", "C32", "C33", "C34", "E44", "B44")
        For i = 0 To UBound(TbLst)
            .Cells(LaLigne, i + 1) = Worksheets("Contrat").Range(TbLst(i)).Value
        Next i
    End If
End With
LaLigne = 0
End Sub
'---------------------------------------------------------------------------------------
' Procedure : btnEFFACE_Click
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet d'effacer la feuille contrat (appel de RAZ)
'---------------------------------------------------------------------------------------
Private Sub btnEFFACE_Click()
 
RAZ
End Sub
'---------------------------------------------------------------------------------------
' Procedure : btnSUPPR_Click
' Author    : Administrateur
' Date      : 07/03/2011
' Purpose   : Permet de supprimer la commande affichée
'---------------------------------------------------------------------------------------
Private Sub btnSUPPR_Click()
Dim Num As String
Dim c As Range
 
Application.ScreenUpdating = False
'***** test si ligne commande existe deja *****
With Worksheets("Liste")
    Num = Worksheets("Contrat").Range("E8").Value
    If Trim(Num) <> "" Then
        Set c = .Range("A:A").Find(Num, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            If MsgBox("Voulez-vous supprimer la commande  " & Num & "?", vbYesNo + vbDefaultButton2 + vbExclamation) = vbNo Then Exit Sub
            c.EntireRow.Delete
            Set c = Nothing
        End If
    End If
End With
LaLigne = 0
End Sub

Encore merci de votre aide,

Claude

[kiki29]

Salut, une fois de plus tu as sous les yeux tous les éléments pour l'adapter à ton contexte

par exemple pour

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Impression NomFichier

qu'y a-t-il dans le code proposé ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Impression sFichier, y

et y n'est pas là pour rien ?

[patricktoulon]

bonjour

au plus simple pour que ca soit automatique

il te faut :
tester si le dossier existe
le créer si il n'existe pas
enregistrer le fichier dans le dossier

un exemple
adapte le chemin car moi je n'ai pas "document and setting " je suis sur seven!!!!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub enregistrer()
   Dim année As String
   Dim chemin_dossier As String
   année = Format(Date, "yyyy") 'donne l'année
 
 'on créé le chemin complet a adapter a ton cas
 
 chemin_dossier = "C:\" & année
 
    'ici on va tester si le dossier existe en appelant la fonction "DossierExiste" avec le chemin créé précedament
    If DossierExiste(chemin_dossier) = False Then
    'si il n'existe pas  on le créé
    MkDir (chemin_dossier)
Else
'sinon on sort de la boucle
End If
'maintenant on va enregistrer le fichier dans le dossier portant le nom de l'année
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin_dossier & "\" & "copie de la feuille.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
End Sub
 
'fonction qui verifie si le dossier existe
Function DossierExiste(NomDossier As String) As Boolean
    DossierExiste = Dir(NomDossier, vbSystem + vbDirectory + vbHidden) <> ""
End Function

ps: tu avait ca dans la faq et meme les contributions un peu de recherches ne fait pas de mal
au plaisir

[Klode784]

bonjour

adapte le chemin car moi je n'ai pas "document and setting " je suis sur seven!!!!

Bonjour et merci pour ton aide! Je n'ai pas non plus de "document and settings" parce que je suis également sur Windows 7. J'ai essayé ton code mais il ne fonctionne pas. Je ne suis pas vraiment doué sur VBA, je commence seulement. Si tu pourrais être plus précis sur les choses que je dois adapter, j'apprécierais beaucoup.

ps: tu avait ca dans la faq et meme les contributions un peu de recherches ne fait pas de mal
au plaisir

Je travaille depuis quelques jours à me trouver des solutions. Si je demande de l'aide pour faire cela, c'est parce que j'ai fait des recherches et trouvé que cela était possible. J'ai aussi essayé d'adapter les solutions que j'ai trouvé. J'ai seulement un peu de misère avec les formules. C'est encore un peu du chinois. Je ne force personne à m'aider, après tout c'est un forum d'entraide et on ne peut pas tout connaître en débutant. Je n'ai jamais pris de cours en excel ni vba.

Si cela peut aider, j'ai un dossier nommé "ventes" et mon classeur est dans ce dossier. J'ai également dans ce même dossier un sous-dossier "2010" et un autre "2011". L'année est sur la feuil1 dans la cellule "B18" du classeur sous forme de date "yyyy-mm-jj" et c'est sous "yyyy" qu'il faut sauvegarder la commande en PDF dans le bon sous-dossier ou le créer s'il n'existe pas.

Merci quand même, un jour je serai peut-être aussi expert que toi et partagerai mon savoir avec plaisir, en attendant c'est moi qui ai besoin d'aide. J'aime bien aussi avoir tous les détails afin de bien comprendre et ainsi apprendre.

Claude

[SfJ5Rpw8]

Bonjour à tous,

J'ai essayé d'intégrer le code fourni de différentes façons mais soit rien ne se ....
...

je comprends pas dans ce dernier code ne semble pas modifié ? montre nous tes essais infructueux.

tu utilise ThisWorkBook.path ... et donc le répertoire abritant ta macro .. ou sont placés les répertoire de destination par rapport à celui-ci ? par exemple :
au même niveau :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
RepertoirdeBase\Macro\ FichierMacro.x..
RepertoirdeBase\2011\
RepertoirdeBase\2012\

[patricktoulon]

bonjour

oui dans ce cas la c'est encore plus simple comme bill viens de le dire précédemment

puisque les dossier 2010,2011,2012,ect... doivent ce trouver dans le dossier ou ce trouve le classeur c'est le "thisworkbook.path" qui veut dire le dossier de ce classeur qui faut utiliser

donc reprenons:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub enregistrer()
   Dim année As String
   Dim chemin_dossier As String
   année = Format(Date, "yyyy") 'donne l'année
 
 'on créé le chemin complet a adapter a ton cas
 
 chemin_dossier = thisworkbook.path & "\"  & année
 
    'ici on va tester si le dossier existe en appelant la fonction "DossierExiste" avec le chemin créé précédemment
    If DossierExiste(chemin_dossier) = False Then
    'si il n'existe pas  on le créé
    MkDir (chemin_dossier)
Else
'sinon on sort de la boucle
End If
'maintenant on va enregistrer le fichier dans le dossier portant le nom de l'année
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin_dossier & "\" & "copie de la feuille.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
End Sub
 
'fonction qui vérifie si le dossier existe
Function DossierExiste(NomDossier As String) As Boolean
    DossierExiste = Dir(NomDossier, vbSystem + vbDirectory + vbHidden) <> ""
End Function

je ne vois aucune raisons pour la quelle ça ne fonctionnerait pas chez toi
si ce n'est que tu n'a peut être pas la mise a jour pour 2007 qui te permet de sauver en pdf vérifie ce point très important bien que je n'en suis pas sur mais elle fait partie désormais des mises a jour office automatiques je crois

allez bon courage
au plaisir

[kiki29]

Salut, Bis Repetita Placent .....
ce que tu fais avec MkDir et DossierExiste, SHCreateDirectoryEx le fait en une seule passe, sans probleme de profondeur de dossiers / Sous-Dossiers contrairement à MkDir

[patricktoulon]

bonjour kiki29

je ne suis pas sur de ce que tu dis

Salut, Bis Repetita Placent .....
ce que tu fais avec MkDir et DossierExiste, SHCreateDirectoryEx le fait en une seule passe, sans probleme de profondeur de dossiers / Sous-Dossiers contrairement à MkDir

au mieux il écrase le dossier existant je n'en suis pas sur je vais étudier la question

EDIT:!!!

je viens d'essayer plusieurs fois et effectivement ça fonctionne
par contre il faudra m'expliquer comment il fait le test
ou alors pourquoi je n'est pas d'avertissement que le dossier existe
peut être du a tes deux variables "0&"
enfin j'aurais aimé comprendre

au plaisir

[kiki29]

Salut, dans le post# 2 j'ai donné les liens vers le site Microsoft qui donne les valeurs renvoyées par SHCreateDirectoryEx

[Klode784]

bonjour

je ne vois aucune raisons pour la quelle ça ne fonctionnerait pas chez toi
si ce n'est que tu n'a peut être pas la mise a jour pour 2007 qui te permet de sauver en pdf vérifie ce point très important bien que je n'en suis pas sur mais elle fait partie désormais des mises a jour office automatiques je crois

allez bon courage
au plaisir

Bonjour à tous du forum, excusez-moi si je n'ai pas répondu avant, je n'étais pas disponible. Mon fichier s'enregistre déjà en format PDF avec la mise à jour de 2007. Tout ce que j'ai besoin, c'est qu'il soit enregistré dans le bon dossier de l'année correspondante à la date de départ, ou de créer le dossier s'il n'existe pas. C'est probablement pour ça qu'il ne se passe rien car l'opération de sauvegarde en PDF se fait déjà automatiquement. J'ai essayé avec une commande en 2012 sans dossier et le dossier ne se crée même pas. Si cela aurait fonctionné ne serait-ce qu'à moitié, il aurait au moins créé le dossier 2012. C'est ce que j'en ai conclu avec les tests que j'ai fait.

Claude

[kiki29]

Salut, désespérant , je t'ai apporté une solution qui fonctionne et tu n'as qu'à l'intégrer à ton contexte. Un forum n'est pas une usine de code clef en main et suppose un minimum d'effort réciproque

[Klode784]

Salut, désespérant , je t'ai apporté une solution qui fonctionne et tu n'as qu'à l'intégrer à ton contexte. Un forum n'est pas une usine de code clef en main et suppose un minimum d'effort réciproque

Salut! Merci pour ton aide, c'est très apprécié.

Claude

[Klode784]

Bonsoir à tous,

J'ai essayé les solutions proposées ici, mais je ne comprends toujours pas pourquoi cela ne fonctionne pas.

Je ne cherche pas une solution complète et intégrée à mon classeur, mais surtout à comprendre et apprendre. Si on pouvait m'aider à savoir comment intégrer une solution et les changements que je dois adapter à ma situation, je pourrais sûrement me débrouiller.

Merci

Claude

[kiki29]

Salut, chez moi cela fonctionne ( sauf la partie OutLook puisque je ne l'utilise pas )

Code ajouté dans Feuil1 Sheets("Contrat")

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
 
Private Function CreationDossier(sDossier As String) As Long
' Pour valeur retournée par CreationDossier
'   Voir http://msdn.microsoft.com/en-us/library/bb762131(VS.85).aspx
'   et   http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
    CreationDossier = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Code Impression modifié pour la prise en compte du nom du dossier de sauvegarde

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Private Sub Impression(ByVal Fichier As String)
Dim y As String, sDossier As String
    y = Year(Sheets("Contrat").Range("B18"))
    sDossier = ThisWorkbook.Path & "\" & y
    CreationDossier sDossier
 
    With ThisWorkbook
        If MsgBox("Voulez-vous imprimer la commande?", vbYesNo) = vbNo Then Exit Sub
        'Ne pas imprimer
        ThisWorkbook.Sheets("Contrat").ExportAsFixedFormat Type:=xlTypePDF, Filename:=sDossier & "\" & Fichier & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Application.DisplayAlerts = True
    End With
End Sub