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
| Sub Nom_fichier()
Dim Fic As String
Dim nomFichier As String
Dim RIB As String
Dim RIB2 As String
Dim FichierEnvoye As String
Dim Cdo_Message As Object
Fic = InputBox("Entrez le chemin complet du dossier contenant les fichiers", "Fichiers à envoyer")
For k = 1 To Worksheets("Feuil2").Range("A65536").End(xlUp).Row
RIB = Worksheets("Feuil2").Cells(k, 1).Value
RIB2 = RIB & ".xls"
If Not Right(Fic, 1) = "\" Then Fic = Fic & "\"
FichierEnvoye = Fic & RIB2
If Len(Dir(FichierEnvoye)) > 0 Then
On Error Resume Next
Set Cdo_Message = CreateObject("CDO.Message")
On Error Resume Next
If Err Then
MsgBox "CDO non installé"
Exit Sub
Else
With Cdo_Message
.From = "octu@grassavoye.com"
.To = Worksheets("Feuil2").Cells(k, 2)
.Subject = Worksheets("Feuil2").Cells(k, 1)
.HTMLBody = "Test"
.AddAttachment (FichierEnvoye)
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.xxxx.com"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Update
On Error Resume Next
.Send
If Err <> 0 Then
MsgBox Err.Number & Err.Description & Err.LastDllError
Err.Clear
End If
End With
End If
End If
Next k
On Error GoTo 0
End Sub |
Partager