R15500 [VBA] Envoyer un fichier OFFICE par mail
Publié par Oliv le Vendredi 16 février 2007 15:34

Ci dessous une tite macro à mettre dans n'importe quel programme office(enfin presque).

il faut référencer "Microsoft CDO for Windows 2000 Library"

et il faut que la macro ne soit pas dans le fichier à envoyer.

Pour Access on ne peut pas envoyer la base active avec cette méthode car il faut la fermer et donc plus de code, il doit y a voir une solution mais je ne pratique pas le VBA Access.

Pour Publisher c'est presque la même chose je ne sais pas comment on lance une macro se trouvant dans un autre document.

Mais on peut boucler sur tous les documents ouverts et choisir celui à envoyer.

Ici l 'exemple est donné avec des inputbox pour demander les infos d'envoi

C 'est bien sûr mieux avec un Userform.

La macro à lancer est donc GoMail

Pour simplifier il faut que le document ait été enregistré au préalable.

Dans cet exemple pas de pb de sécurité mais le mail est envoyé directement .


 Public Emetteur As String
Public Destinataire As String
Public Sujet As String
Public CorpsBrut As String
Public Fichier As String
 
 
Function SendMailCDO(Sender As String, Receiver As String, _
                     Subject As String, BodyText As String, _
                     Optional BodyHTML As String, _
                     Optional Cc As String, _
                     Optional Bcc As String, _
                     Optional Attach1 As String)
 
    Dim Cdo_Message As New CDO.Message
 
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
 
    With Cdo_Message
        .To = Receiver
        .From = Sender
        .Subject = Subject
        .Cc = Cc
        .Bcc = Bcc
        '.DSNOptions = 2 ' Delivery Status Notification
        'pour indiquer le Corps du Mail en brut.
        .TextBody = BodyText
        'Décommenter pour indiquer le Corps du Mail en HTML.
        '.HTMLBody = BodyHTML
        'Pour envoyer une page WEB en tant que corps du Mail.
        '.CreateMHTMLBody _
         "http://groups.google.com/group/microsoft.public.fr.outlook", _
         CDO.CdoMHTMLFlags.cdoSuppressNone , "", ""
 
        'ou se trouvant sur son pc
        '.CreateMHTMLBody "file:\\C:\INFORMAT\exemples\événements.htm"
 
 
        If Attach1 <> "" Then
            If Len(Dir(Attach1)) > 0 Then
                .AddAttachment (Attach1)
            Else: MsgBox Attach1 & vbCr & "Ce fichier sera ignoré", _
                         , "Fichier à Attacher introuvable !"
            End If
        End If
 
        'Cette commande envoi le Mail
        .Send
    End With
    Set Cdo_Message = Nothing
End Function
 
 
 
Function GetSMTPServerConfig() As Object
 
    Dim Cdo_Config As New CDO.Configuration
    Dim Cdo_Fields As Object
    Set Cdo_Fields = Cdo_Config.Fields
 
    With Cdo_Fields
        .item(cdoSendUsingMethod) = cdoSendUsingPort
        '.Item(cdoSMTPServer) = "smtp.easynet.fr"
        '.Item(cdoSMTPServerPort) = 25
        .Update
    End With
 
    Set GetSMTPServerConfig = Cdo_Config
    Set Cdo_Config = Nothing
    Set Cdo_Fields = Nothing
 
End Function
 
 
Sub gomail()
    MsgBox Application.Name
    Select Case Application.Name
    Case "Microsoft Excel"
        EnvoiClasseur
    Case "Microsoft Word"
        EnvoiDoc
    Case "Microsoft Access"
        'Envoibase
    Case "Microsoft PowerPoint"
        EnvoiPpt
    Case "Microsoft Publisher"
        'EnvoiCompo
    End Select
End Sub
 
Private Sub EnvoiClasseur()
 
    Set FichierXls = Application.ActiveWorkbook
    If FichierXls.Saved = True Then
        Fichier = FichierXls.FullName
        FichierXls.Close
        Emetteur = InputBox("Emetteur ?", "Envoi par Mail", "Emetteur par défault")
        Destinataire = InputBox("Destinataires (séparés par des ;)", _
                                "Envoi par Mail ")
        Sujet = InputBox("Objet du mail ?", "Envoi par Mail", "Test CDO " & _
                                                              Application.Name)
        CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
                             "Lire le fichier joint")
        Call SendMailCDO(Emetteur, Destinataire, Sujet, CorpsBrut, , , , _
                         Fichier)
 
        Workbooks.Open Fichier
        MsgBox "Mail envoyé"
 
    Else
 
        MsgBox "Vous devez enregistrer votre fichier avant de pouvoir l'envoyer" _
             , , "Erreur"
 
    End If
End Sub
Private Sub EnvoiDoc()
 
    Set FichierDoc = Application.ActiveDocument
    If FichierDoc.Saved = True Then
        Fichier = FichierDoc.FullName
        FichierDoc.Close
        Emetteur = InputBox("Emetteur ?", "Envoi par Mail", "Emetteur par défault")
        Destinataire = InputBox("Destinataires (séparés par des ;)", _
                                "Envoi par Mail ")
        Sujet = InputBox("Objet du mail ?", "Envoi par Mail", _
                         "Test CDO " & Application.Name)
 
        CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
                             "Lire le fichier joint")
 
        Call SendMailCDO(Emetteur, Destinataire, Sujet, CorpsBrut, _
           , , , Fichier)
 
        Documents.Open Fichier
        MsgBox "Mail envoyé"
    Else
 
        MsgBox "Vous devez enregistrer votre fichier avant de pouvoir l'envoyer" _
             , , "Erreur"
 
    End If
End Sub
 
 
 
Private Sub EnvoiPpt()
 
    Set FichierPpt = Application.ActivePresentation
    If FichierPpt.Saved = True Then
        Fichier = FichierPpt.FullName
        FichierPpt.Close
        Emetteur = InputBox("Emetteur ?", "Envoi par Mail", "Emetteur par défault")
        Destinataire = InputBox("Destinataires (séparés par des ;)", _
                                "Envoi par Mail ")
        Sujet = InputBox("Objet du mail ?", "Envoi par Mail", "Test CDO " _
                                                            & Application.Name)
 
        CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
                             "Lire le fichier joint")
 
        Call SendMailCDO(Emetteur, Destinataire, Sujet, CorpsBrut, , , , Fichier)
        Presentations.Open Fichier
        MsgBox "Mail envoyé"
 
    Else
        MsgBox "Vous devez enregistrer votre fichier avant de pouvoir l'envoyer" _
             , , "Erreur"
 
    End If
End Sub