Script vba "enregistrer+pdf+email"

Version imprimable

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:

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

Salut, à partir d'Excel 2007 SP2 le pdf est intégré en natif : donc pas besoin de PDFCreator. Cela allègera d'autant ton code. Sinon c'est peut-être encore un drame du copier/coller sur un code non maitrisé.
Code:

1 2 3 4 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sCheminPDF & "\" & sNomPDF, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False
Code:

1 2 sNomFichier = "C:\Transfert\" & Range("E5") & " " & Format(Now, "ddmmyyyy hhmm") & ".xls" ActiveWorkbook.SaveCopyAs Filename:=sNomFichier

31/10/2012, 11h48
darkv1

Merci pour ta réponse kiki29,
La partie sur le pdf fonctionne (je vais quand même voir pour "alléger" le code).

Mon problème, comme dit plus haut, est plutôt sur la sauvegarde du .xls dans le bon sous-dossier ...

Quand au "drame" du copier/coller, j'ai quand même plus qu'adapté le code a mes besoin et il faut bien commencer un jour ... (ca ne m'empêche pas de lire un max de tutoriels et je m'auto-forme pour le moment).

Merci :)
31/10/2012, 12h05
kiki29

Salut, vérifier l'existence du dossier, placer un

Code:

Debug.Print sNomFichier

et vérifier la syntaxe

Ou en mode debug en plaçant un point d'arrêt puis en mode pas à pas [F5]

Code : Pas d'Option Explicit, déclaration de variables en cours de procédure, indentation fantaisiste etc

J'ai un peu avancé.

J'ai réussi a créer le dossier puis a enregistrer le fichier dedans.

Je remet que la partie du code concernant le .xls puisque le reste marche pour le moment :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub CommandButton1_Click()
 
 
 
Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim SCheminFichier As String
 
    ChDrive "C:\mondossier\"
    MkDir "C:\mondossier\" & Range("E5")
    SCheminFichier = "C:\mondossier\" & Range("E5")
    SNomFichier = SCheminFichier & "\" & Range("E5") & " " & Format(Now, "dd-mm-yyyy hh-mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier
 
 
End Sub

Sauf que ça plante si le sous-dossier dans "mondossier" existe déjà ...

Edit :

En fait , j'ai trouvé :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub CommandButton1_Click()
 
 
 
Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim SCheminFichier As String
 
    ChDrive "C:\mondossier\"
    If Len(Dir("C:\mondossier\" & Range("E5"), vbDirectory)) = 0 Then
    MkDir "C:\mondossier\" & Range("E5")
    End If
    SCheminFichier = "C:\mondossier\" & Range("E5")
    SNomFichier = SCheminFichier & "\" & Range("E5") & " " & Format(Now, "dd-mm-yyyy hh-mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier
 
 
End Sub

Salut, pour la création de Dossiers/Sous Dossiers

Code:

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

Re,
Grâce a tes indications (plus deux ou trois choses trouvées sur le net), j'ai réussi a obtenir ce que je veux.

Donc, maintenant,
ça enregistre bien le .xls et le .pdf dans le sous-dossier crée a partir des données d'une cellule
et avec le nom de fichier récupéré a partir d'une autre cellule
et ensuite ça l’envoi par émail a partir des données récupérées sur encore une autre cellule ( et sans pdf creator).

J'ai aussi allégé le code a partir de tes indications (même si je me demande si j'ai pas encore des trucs en trop ...).

Donc voici le code que j'obtiens :

Code:

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
 
Private Sub CommandButton1_Click()
 
Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim SCheminFichier As String
Dim sNomPDF As String
Dim sCheminPDF As String
    ChDrive "C:\mondossier\"
    If Len(Dir("C:\mondossier\" & Range("E6"), vbDirectory)) = 0 Then
    MkDir "C:\mondossier\" & Range("E6")
    End If
    SCheminFichier = "C:\mondossier\" & Range("E6")
    SNomFichier = SCheminFichier & "\" & Range("E5") & " " & Format(Now, "dd-mm-yyyy hh-mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier
 
    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\mondossier\" & Range("E6")
 
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sCheminPDF & "\" & sNomPDF, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
 
    Dim cell As Range
    Dim strto As String
    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)
 
     Set iConf = CreateObject("CDO.Configuration")
 
    iConf.Load -1 
        Set Flds = iConf.Fields
            With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.monfai.fr"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
 
    Set CdoMessage = New CDO.Message
    With CdoMessage
        .Subject = "monsujet "
        .From = "mon@adressemail.fr"
        .To = strto
        .CC = ""
        .BCC = ""
        .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 CdoMessage = Nothing
 
 
End Sub

Merci encore pour ton aide kiki29