Bonjour,

J'ai lu cette discussion.
Merci de votre aide et de ce précieux code que je recherche depuis plusieurs temps pour un projet.
Dès que je l'introduit dans VBA, celui-ci me dit : " Erreur de compilation Sub ou Function non définie"
et me surligne ces expressions (orange)

Pouvez-vous m'aider SVP, car là, je cale ...

Merci à toute les membres du Forum

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