Discussion :

[darkv1]

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

[kiki29]

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 :

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

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

Code :

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

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

[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

[kiki29]

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

Code :

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

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

[darkv1]

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 :

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
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 :

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
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

[kiki29]

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

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
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