Envoi fichier Excel automatique

Le 17/02/2020 à 17:59

Bonjour,

Je suis entrain de chercher une solution pour l'envoi d'un classeur excel automatiquement en cliquant sur une bouton dans le classeur lui même.

D'après mes recherches, il existe deux méthodes:

1) Via Microsoft Outlook Library (méthode impossible vu la politique de filtrage instaurée dans la société ou je travaille)

2) Via la méthode CDO (méthode impossible vu que le Firewall bloque le module concerné)

Sachant qu'au niveau de notre société, on utilise la messagerie IBM, y a t il selon vous une solution pour rendre ce travail possible.

Merci beaucoup

Le 17/02/2020 à 18:03

Salut hamdiby,

la messagerie IBM? Lotus Notes?

si oui, voir ce sujet https://forum.excel-pratique.com/viewtopic.php?f=2&t=122525&p=749714&hilit=lotus+notes#p749714

ou

et voici un exemple qui fonctionne:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim WatchRange As Range
Dim IntersectRange As Range
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' Open and locate current LOTUS NOTES User
'For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row
'If Range("A" & x) = "Overdue" Then
Set Session = CreateObject("Notes.NotesSession")
Set WatchRange = Range("B2:H15")
Set IntersectRange = Intersect(Target, WatchRange)
If IntersectRange Is Nothing Then
'Cells(1, 1).Value = Cells(1, 1).Value
Else
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Message"
'stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
'Recipient = Worksheets("Sheet1").Range("B" & x).Value
MailDoc.SendTo = "myemail@mailserver.com"
MailDoc.Subject = "Document content-change notification"
MailDoc.Body = "I changed document content. Please be informed."
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End If
End With
End Sub

un autre

Sub Send_Mail()

Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim Recipient As String
Dim attachment As String

Set Session = CreateObject("Notes.NotesSession")
Set Maildb = Session.currentdatabase
Set MailDoc = Maildb.CreateDocument

attachment = "<Pfad zur Datei>"

MailDoc.Form = "Memo"
Recipient = "name@domain.tld"
MailDoc.sendto = Recipient
MailDoc.Subject = "Das ist Ihr Betreff !!"
MailDoc.body = "Hier steht der Mailtext"

' Zum Versenden der angegebenen Datei von der Variable attachment                        
stAttachment = ActiveWorkbook.FullName
Set AttachME = MailDoc.CREATERICHTEXTITEM("stAttachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", attachment, "stAttachment")

MailDoc.SAVEMESSAGEONSEND = True
MailDoc.Send 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing

End Sub

@++

Le 18/02/2020 à 12:58

Bonjour m3ellem1,

Merci beaucoup pour votre réponse rapide, c'est très gentil de votre part.

Toutefois, je n'ai pas réussi à utiliser les différents codes pour les adapter à mon fichier et mon besoin.

Je serai très reconnaissant si vous arrivez à m'aider en incorporant l'un des codes à mon fichier en pièce jointe.

Merci beaucoup encore une fois

4message-mail.xlsm (36.03 Ko)
Le 18/02/2020 à 22:50

Salut hamdiby,

pas besoin de me vouvoyer, sinon je répond plus

Bon afin de pouvoir t'aider, il me faut plus d'informations!

Est ce qu'il y a un message d'erreur?

si oui, j'ai besoin du message d'erreur et de la ligne du code ou ca bloque exactement.

@++

Le 19/02/2020 à 08:26

Au fait aucun message d'erreur ne m'affiche. Sauf que, vue que je ne suis même pas débutant en VBA, je n'arrive pas à spécifier le code pour que le mail:

  • Prend la liste des destinataires des champs spécifiés
  • Mettre l'objet que je défini dans le champs spécifié aussi
  • Et enfin rattacher le fichier dans le mail.

8message-mail.xlsm (38.13 Ko)
Le 21/02/2020 à 15:09

Salut hamdyby,

bon pour faire un test, essaie de mettre des adresses mail corréctes dans la plage D15:D18 (à la place de xxxxx@...., yyyyy@... etc)

et essaie cette macro pour voir si premièrement tu peux envoyer les mails!

Sub EnvoiMail()
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' Ouvrir LOTUS NOTES et localiser l'utilisateur actuel
For x = 15 To Cells(Rows.Count, "B").End(xlUp).Row
If Range("B" & x) <> "" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Creer un nouveau memo et sujet
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)

' Selectionner la plage des adresses mail
Recipient = Worksheets("Feuil1").Range("D" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Envoi Mail depuis Excel"
MailDoc.Body = "Merci de me renvoyer une réponse." & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True

errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End If
Next x
End With
End Sub
Le 22/02/2020 à 13:02

Bonjour,

Merci bien pour votre réponse. Tout va bien. Juste, je veux envoyer le fichier ouvert en pièce jointe dans le mail et que le récepteur du mail ouvre le fichier dans une autre feuille A.

Le 22/02/2020 à 13:27

Oui je sais, je voulais juste tester si l’envoi fonctionne!

Ce soir je vais m’y pencher

Le 22/02/2020 à 13:30

Très bien, je vous remercie beaucoup.

En attendant, je ne sais pas si ce code puisse m'aider ou non:

For i = 1 To iFichier
    ReDim Preserve attachment(i)
    attachment(i) = "C:\Users\13426012\Desktop\Message mail" & Format(dDate) & "(" & i & ").xlsm"
    NameAttachment = "Attachement(" & i & ")"
    Set AttachME = doc.CREATERICHTEXTITEM(NameAttachment)
    Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", attachment(i), NameAttachment)
Next i
Le 23/02/2020 à 04:37

Salut,

essaie premièrement avec un fichier

Sub manio()
Attachment1 = "C:\Users\13426012\Desktop\Message mail_XXXXXXX_.xlsm" ' adapte le nom du fichier
If Attachment1 <> "" Then
    Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
    Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment1")
    MailDoc.CREATERICHTEXTITEM (Attachment1)
End If

combien de fichier il faut envoyer?? il faut déclarer et définir iFichier!!

et c'est quoi dDate??? 

For i = 1 To iFichier
    ReDim Preserve attachment(i)
    attachment(i) = "C:\Users\13426012\Desktop\Message mail" & Format(dDate) & "(" & i & ").xlsm"
    NameAttachment = "Attachement(" & i & ")"
    Set AttachME = MailDoc.CREATERICHTEXTITEM(NameAttachment)
    Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", attachment(i), NameAttachment(i))
Next i

XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

et sinon voici ma proposition,

Sujet ==> la céllule C6 FIXE

Message ==> la céllule C8 FIXE

Adresse Mail ==> la céllule D15 jusqu'à D17 VARIABLE

Chemin d'attachment ==> la céllule E15 jusqu'à E17 VARIABLE

Sub EnvoiMail()
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
Dim Attachment1 As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' Ouvrir LOTUS NOTES et localiser l'utilisateur actuel
For x = 15 To Cells(Rows.Count, "B").End(xlUp).Row
If Range("B" & x) <> "" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Creer un nouveau memo et sujet
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)

' Selectionner la plage des adresses mail
Recipient = Worksheets("Feuil1").Range("D" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = Worksheets("Feuil1").Range("C6").Value
MailDoc.Body = Worksheets("Feuil1").Range("C8").Value & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True

Attachment1 = Worksheets("Feuil1").Range("E" & x).Value ' si la colonne E contient les chemins des fichiers à envoyer!!!!
If Attachment1 <> "" Then
    Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
    Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment1")
    MailDoc.CREATERICHTEXTITEM (Attachment1)
End If

MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True

errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End If
Next x
End With
End Sub

@++

Le 06/03/2020 à 03:47

Salut hamdiby929,

alors y a du nouveau?

Le 10/03/2020 à 16:45

Bonjour m3ellem1,

Merci pour l'intérêt que vous portez pour mon sujet, ci-joint le dernier fichier que grâce à vos interventions j'ai pu le finaliser, toutefois, je rencontre toujours ce problème: les adresses en vert dans le fichier joint peuvent recevoir le fichier, c'est à dire les adresses dans la ligne 1, alors que les adresses dans les lignes suivantes (les adresses en rouge) ne sont pas prises en considération.

Aussi, le code que j'ai mis pour que le message soit sauvegardé dans la boite "Envoyé" ne marche pas.

Ci-joint le fichier et ci-dessous le code:

5mailing.xlsm (41.41 Ko)
Sub Mainx()
Dim x As Integer
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim RECIPIENT As Variant
Dim Var As Variant
Dim flag As Boolean
Dim SaveIt As Boolean

For x = 15 To Cells(Rows.Count, "D").End(xlUp).Row
If Range("D" & x) <> "" Then

Set oSess = CreateObject("Notes.NotesSession")
Set oDB = oSess.GETDATABASE("", "")
Call oDB.OPENMAIL
flag = True
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")

If Not flag Then
MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FilePath
GoTo exit_SendAttachment
End If
On Error GoTo err_handler

'Building Message
RECIPIENT = Worksheets("A").Range("D" & x).Value
Set oDoc = oDB.CREATEDOCUMENT
Set oItem = oDoc.CREATERICHTEXTITEM("BODY")
oDoc.Form = "Memo"
oDoc.Subject = Range("A!C6").Value
oDoc.SendTo = Range("D" & x).Value
oDoc.CopyTo = Range("E" & x).Value
oDoc.Body = Range("A!C8").Value

'Attaching DATABASE
Call oItem.EmbedObject(1454, "", "C:\Users\13426012\Desktop\TDB Suivi Journalier Etirable2.xlsm")
oDoc.visable = True
'Sending Message
oDoc.Send False
exit_SendAttachment:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
oDoc.SAVEMESSAGEONSEND = SaveIt
MsgBox "Tableau envoyé avec succès"

'Done
Exit Sub
err_handler:
If Err.Number = 7225 Then
MsgBox "File doesn't exist"
Else
MsgBox Err.Number & " " & Err.Description

End If
On Error GoTo exit_SendAttachment
End If
Next x
End Sub
Le 10/03/2020 à 21:38

Salut hamdiby,

pour que le message soit sauvegardé dans la boite "Envoyé" il faut changer la valeur de SaveIt!

De préférence essaie comme ca:

oDoc.SAVEMESSAGEONSEND = TRUE

Pour l'autre problème est ce qu'il y a un message d'érreur? car je ne vois pas pourquoi ca envoi pas

Le 11/03/2020 à 08:30

Bonjour,

Pour le code du sauvegarde ça marche, merci.

Pour la liste des envois je n'ai pas encore réussi. J'ai essayé plusieurs options (trouvées sur le net) mais ça ne marche pas.

Bonne journée

Le 11/03/2020 à 08:32

oui mais le premier message est envoyé non?

c'est juste les autres mails qui posent le problème?

Le 11/03/2020 à 09:07

Absolument

Rechercher des sujets similaires à "envoi fichier automatique"