Petit prob d'envoie de courriels

Valtrase · 7 Juillet 2019

Bonjour à tous
Je ne sais pas sur quel bouton j'ai pu appuyé, mais là je deviens fou.

J'ai un code récupéré sur la toile qui marchais très bien jusqu’à présent.Et là badaboum plus rien ne fonctionne.
Et pourtant la référence est bien cochée.
Ce code fait partie de ce module :

VB:

Option Explicit
Option Compare Text

'————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' Nom           : modCurrent
' Auteur        : Jean-Paul
' Date          : 03/07/2019
' Description   : Module de base de ce classeur

'————————   CONSTANTES GENERALES POINTAGE   —————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————
Public Const Default_LineHeader = "XXX Remplaçant: [Nom] [Prénom] Date du transfert: [Date]"
Public Const Default_Signature_Name = "XXX.htm"

'————————   REFERENCES   ————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' Microsoft Outlook XX.0 Object Library


Sub EnvoyerEmail()
' par Excel-Malin.com ( https://excel-malin.com )
' Lien https://excel-malin.com/codes-sources-vba/envoyer-un-email-avec-excel/

    On Error GoTo EnvoyerEmail_Erreur
    Dim oOutlook As Outlook.Application, WasOutlookOpen As Boolean, oMailItem As Outlook.MailItem
    Dim Body As Variant, Subject As String
    Dim Filename1 As String, LineHeader As String, sFolder As String
    Dim bOpenAfterPublish As Boolean
    
    'Doit-on ouvrir le document PDF aprés enregistrement ?
    'La fonction GetParm(Key, DefaultValue) me serts à récupérer un paramètres dans une feuille cachée
    bOpenAfterPublish = GetParam("Pdf.Open", False)

    'On récupère le chemin d'enregistrement des fichiers PDF
    sFolder = AddBackslash(GetParam("Pdf.Path", DossierSpecial(Bureau)))

    'Si le dossier n'existe pas alors on ouvre la fenêtre des paramètres
    'ToDo tester si Rebuild.Path si oui reconstruire le chemin
    If fsoFolderExist(sFolder) = False Then
        DisplayErr sFolder, FolderNoFound
        UserForm1.Show
        Exit Sub
    End If

    'On met en forme le sujet
    Subject = Replace(GetParam("Pdf.Name", "Titre du sujet"), "[remplaçant]", _
                      IIf(GetParam("Salarie.Entreprise", 1) = 2, " remplaçant ", " ")) & _
                      Range("Semaine")

    'Doit-on sauvegarder et envoyer un fichier Pdf ou Xls ?
    Select Case GetParam("Save.As", 0)
        Case 0                                                  'Save as PDF
            Filename1 = sFolder & _
                        Subject & ".pdf"
            ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
                                               Filename:=Filename1, _
                                               Quality:=xlQualityStandard, IncludeDocProperties:=False, _
                                               IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=bOpenAfterPublish

        Case 1                                                  'Save as Xlsm
            Filename1 = sFolder & _
                        Subject & ".xlsm"
            ActiveWorkbook.SaveCopyAs Filename1

        Case Else

    End Select

    'On mets en forme une ligne d'entête du message
    LineHeader = "<H3> <B> " & FormatBody(Range("Line_Header")) & " </B> </H3>"

    'Début du message
    Body = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.0 Transitional//EN"">" & _
           "<HTML><HEAD>" & _
           "<META http-equiv=Content-Type content=""text/html; charset=iso-8859-1"">" & _
           "<META content=""MSHTML 6.00.2800.1516"" name=GENERATOR></HEAD>" & _
           "<BODY><DIV STYLE=""font-size: 12px; font-face: Book Antiqua;"">"

    'Doit-on rajouter la ligne d'entête
    If GetParam("LineHeader.Insert") = True Then
        Body = Body & LineHeader & "<br>"
    End If

    'On rajoute notre message pré-enregistré
    Body = Body & FormatBody(GetParam("Message.Body"), True)

    'On prépare Outlook
    PreparerOutlook oOutlook

    Set oMailItem = oOutlook.CreateItem(0)

    'On récupère les destinataires
    Dim SendToCopy As String: SendToCopy = GetParam("Send.ToCopy", "")
    Dim SendTo As String: SendTo = GetParam("Send.To", "XXXX@XXX.fr>")
    Dim SendFrom As String: SendFrom = GetParam("Send.From", "XXXX@XXXX.fr")
    '    Dim SigString As String
    '    Dim Signature As String

    'Création de l'email
    With oMailItem
        '.Sender = Range("Sender")
        .From = SendFrom
        .To = SendTo
        If SendToCopy <> "" Then .CC = SendToCopy
        .Subject = Subject

        'email formaté comme HTML
        .BodyFormat = olFormatHTML
        .HTMLBody = Body & "<br><br>" & .HTMLBody               'Signature Ca ne marche pas !!!!!
        .Attachments.Add Filename1
        If GetParam("View.Mail", True) = True Then
            .Display                                            '<- affiche l'email (si vous ne voulez pas l'afficher, mettez cette ligne en commentaire)
        End If

    End With

EnvoyerEmail_Exit:
    If (Not (oMailItem Is Nothing)) Then Set oMailItem = Nothing
    If (Not (oOutlook Is Nothing)) Then Set oOutlook = Nothing

    Exit Sub

EnvoyerEmail_Erreur:

    MsgBox "Le mail n'a pas pu être envoyé..." & vbNewLine & Err, vbCritical, "Erreur"
    Resume EnvoyerEmail_Exit
End Sub

Private Sub PreparerOutlook(ByRef oOutlook As Object)
'par Excel-Malin.com ( https://excel-malin.com )
'Ce code vérifie si Outlook est prêt à envoyer des emails... Et s'il ne l'est pas, il le prépare.

    On Error GoTo PreparerOutlookErreur


    On Error Resume Next
    'vérification si Outlook est ouvert
    Set oOutlook = GetObject(, "Outlook.Application")

    If (Err.Number <> 0) Then                                   'si Outlook n'est pas ouvert, une instance est ouverte
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    Else                                                        'si Outlook est ouvert, l'instance existante est utilisée
        Set oOutlook = GetObject("Outlook.Application")
        oOutlook.visible = True
    End If
    Exit Sub

PreparerOutlookErreur:
    MsgBox "Oups..." & vbNewLine & "Nous n'avons pas pu charger Outlook !"
End Sub

'Fonction qui doit servir à entrer une signature dans le message
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function

Private Function FormatBody(strString As String, Optional CarriageReturn As Boolean = False) As String
    Dim strTemp As String
    strTemp = Replace(Replace(Replace(Replace(strString, "[Nom]", StrConv(Range("Nom"), vbProperCase)), _
                                         "[Prénom]", StrConv(Range("Prénom"), vbProperCase)), "[Semaine]", Range("Semaine")), vbCrLf, "<br>")
                                         strTemp = Replace(strTemp, "[Date]", Format(Now, "dd-mm-yyyy hh:mm"))
    If CarriageReturn Then strTemp = strTemp & "<br>"
FormatBody = strTemp

End Function

Merci à tous ceux qui voudrons bien y jeter un oeil

Dranreb · 8 Juillet 2019

Bonsoir.
Je n'ai pas Outlook alors je ne pourrai pas vous aider d'avantage, mais, bizarre un plantage après On Error Resume Next !
Vérifiez menu Outils, Options…, onglet Général, rubrique Récupération d'erreur si ce n'est pas Arrêt sur toutes les erreurs qui serait malencontreusement coché.

Valtrase · 16 Juillet 2019

Bonjour tout le monde
Bon en fait tout est venu du plantage d'un disque dur qui a mis le bo...l dans Windows, donc réinstallation de Windows et de toutes les applications est c'est repartis, je note résolu

Petit prob d'envoie de courriels

Valtrase

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Valtrase

XLDnaute Occasionnel

Discussions similaires

Petit prob d'envoie de courriels

Valtrase

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Valtrase

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency