Bonjour,
J'ai un petit script VBA sous Excel 2010 me servant a enregistrer une feuille sous .xls et sous .pdf puis qui va envoyer le .pdf a une adresse email.

Ca fonctionne bien mais j'ai un soucis (oui, sinon, vous vous doutez bien que je poserai pas une question ici )

Je n'arrive pas a enregistrer le .xls dans un sous dossier (que le script doit créer a partir des données d'une cellule).

Ca fonctionne pour le .pdf mais pas le .xls.
Je me doute une peu d'ou vient le probleme (premieres lignes apres les declarations) mais comme je ne pratique le VBA que depuis une semaine, je peche un peu sur ce probleme.

Voici mon script dans son etat actuel :
(E6 c'est le nom que doit créer le script pour générer le sous dossier)
(E5 c'est le nom donné aux fichiers .xls et .pdf qui vont dans le meme sous dossier)

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
 
Private Sub CommandButton2_Click()
 
 
Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
'Pour créer le sous dossier du xls
 ChDrive "C"
 ChDir "C:\Users\xxx\Desktop\DOCUMENTS\yyy\zzz\"
 SNomFichier = "C:\Users\xxxx\Desktop\DOCUMENTS\yyy\zzz\" & Range("E5") & "-" & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " " & Hour(Time) & "H" & Minute(Time) & ".xls"
 ActiveWorkbook.SaveCopyAs Filename:=SNomFichier
'pour créer le pdf
    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\Users\xxx\Desktop\DOCUMENTS\yyy\zzz\" & Range("E6")
 
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
 
    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With
 
    ActiveSheet.PageSetup.PrintArea = "A1:O122"
    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"
 
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
 
    JobPDF.cPrinterStop = False
 
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop
 
    Application.Wait Now + TimeValue("00:00:05")
 
    JobPDF.cClose
    Set JobPDF = Nothing
'partie pour l'envoi via email    
     Dim cell As Range
    Dim strto As String  'je recupere l'adresse mail donnée dans une cellule
    On Error Resume Next
    For Each cell In ThisWorkbook.Sheets("Sheet1") _
        .Range("K5").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    On Error GoTo 0
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
 
 
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set iConf = CreateObject("CDO.Configuration")
'pour envoyer via mon provider sans outlook
    iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.bbox.fr" 'à adapter
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
 
'mise en forme du mail et envoi   
    Set iMsg = CreateObject("CDO.Message")
    With iMsg
    Set .Configuration = iConf
    .To = strto
    .From = """Mon mail""monmail@aaa.fr" 
    .Subject = "Mon sujet " 
    .TextBody = "Bonjour, Veuillez trouver ci-joint la Feuille du " & Day(Date) & "." & Month(Date) & "." & Year(Date) & " a " & Hour(Time) & "H" & Minute(Time)
      .AddAttachment sCheminPDF & "\" & sNomPDF
      .Send
 End With
 Set iMsg = Nothing
 
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
End Sub
Merci de votre aide