Envoyer un e-mail HTML via IBM Notes à l'aide de VBA?

J'utilise le code suivant pour envoyer un e-mail HTML via Excel et IBM Notes en utilisant vba.Envoyer un e-mail HTML via IBM Notes à l'aide de VBA?

Voici mon code:

Sub SendEmail() 

Application.DisplayAlerts = False 
Application.ScreenUpdating = False 


Application.CutCopyMode = False 


'Define Variables 
Dim Ref As String 
Dim TrueRef As String 

Dim Attachment As String 
Dim WB3 As Workbook 
Dim WB4 As Workbook 
Dim Rng As Range 
Dim db As Object 
Dim doc As Object 
Dim body As Object 
Dim header As Object 
Dim stream As Object 
Dim session As Object 
Dim i As Long 
Dim j As Long 
Dim j2 As Long 
Dim server, mailfile, user, usersig As String 
Dim LastRow As Long, LastRow2 As Long, WS As Worksheet 
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row 


'Define Depot 
Ref = Range("G" & (ActiveCell.Row)).Value 

    If Ref = "WED" Then 
    TrueRef = "WED" 
    Else 
    If Ref = "WSM" Then 
    TrueRef = "WES" 
    Else 
    If Ref = "NAY" Then 
    TrueRef = "NAY" 
    Else 
    If Ref = "ENF" Then 
    TrueRef = "ENF" 
    Else 
    If Ref = "LUT" Then 
    TrueRef = "MAG" 
    Else 
    If Ref = "NFL" Then 
    TrueRef = "NOR" 
    Else 
    If Ref = "RUN" Then 
    TrueRef = "RUN" 
    Else 
    If Ref = "SOU" Then 
    TrueRef = "SOU" 
    Else 
    If Ref = "SOU" Then 
    TrueRef = "SOU" 
    Else 
    If Ref = "BRI" Then 
    TrueRef = "BRI" 
    Else 
    If Ref = "LIV" Then 
    TrueRef = "LIV" 
    Else 
    If Ref = "BEL" Then 
    TrueRef = "BEL" 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 
    End If 


'Start a session of Lotus Notes 
Set session = CreateObject("Notes.NotesSession") 
'This line prompts for password of current ID noted in Notes.INI 
Set db = session.CurrentDatabase 
Set stream = session.CreateStream 
' Turn off auto conversion to rtf 
session.ConvertMIME = False 


'Email Code 

'Create email to be sent 

Set doc = db.CreateDocument 
doc.Form = "Memo" 
Set body = doc.CreateMIMEEntity 
Set header = body.CreateHeader("Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")") 
Call header.SetHeaderVal("HTML message") 

'Set From 
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:[email protected]>") 
Call doc.ReplaceItemValue("ReplyTo", "[email protected]") 
Call doc.ReplaceItemValue("DisplaySent", "[email protected]") 
Call doc.ReplaceItemValue("Subject", "Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")") 

'To 
Set header = body.CreateHeader("To") 
'Call header.SetHeaderVal("Supplychain-" & TrueRef & "@lidl.co.uk") 
Call header.SetHeaderVal("[email protected]") 


'Email Body 
Call stream.WriteText("<HTML>") 
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">") 
If Hour(Now) > 12 Then 
Call stream.WriteText("<p>Good afternoon,</p>") 
Else 
Call stream.WriteText("<p>Good morning,</p>") 
End If 
Call stream.WriteText("<p>Reference: " & Format(CDate(Range("A" & ActiveCell.Row).Value), "DDMMYY") & " - " & Range("C" & ActiveCell.Row).Value & " - " & Range("D" & ActiveCell.Row).Value & "</p>") 
If ThisWorkbook.Sheets(1).Range("O" & ActiveCell.Row).Value = "Issue Complete" Then 
Call stream.WriteText("<p>Your recent issue has been marked as complete.</p>") 
Else 
Call stream.WriteText("<p>The status of your recent issue has changed.</p>") 
End If 



'Insert Range 
ThisWorkbook.Sheets(1).Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row & ", O" & ActiveCell.Row).SpecialCells(xlCellTypeVisible).Select 
Set Rng = Selection 
Call stream.WriteText(RangetoHTML(Rng)) 
Cells(1, 1).Select 

Call stream.WriteText("<BR><BR><p><a href=""G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Food Specials Delivery Tracker.xlsm"">Click here to view your issue on the Delivery Tracker now.</a></p></br>") 

'Signature 
Call stream.WriteText("<BR><p>Kind regards/Mit freundlichen Gr&#252;&#223;en,</p></br>") 
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>") 

Call stream.WriteText("<table border=""0"">") 
Call stream.WriteText("<tr>") 
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>") 
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>") 
Call stream.WriteText("</tr>") 
Call stream.WriteText("</table>") 


Call stream.WriteText("</font>") 
Call stream.WriteText("</body>") 
Call stream.WriteText("</html>") 

Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT) 

doc.Save True, False 
Call doc.PutInFolder("TEST") 

Call doc.Send(False) 

session.ConvertMIME = True ' Restore conversion - very important 


'Clean Up the Object variables - Recover memory 
    Set db = Nothing 
    Set session = Nothing 
    Set stream = Nothing 
    Set doc = Nothing 
    Set body = Nothing 
    Set header = Nothing 

    'WB3.Close savechanges:=False 

    Application.CutCopyMode = False 

'Email Code 






Application.DisplayAlerts = True 
Application.ScreenUpdating = True 





End Sub 












Function RangetoHTML(Rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2010 
    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 

    'Copy the range and create a new workbook to past the data in 
    Rng.Copy 
    Set TempWB = Workbooks.Add(1) 
    With TempWB.Sheets(1) 
     .Cells(1).PasteSpecial Paste:=8 
     .Cells(1).PasteSpecial xlPasteValues, , False, False 
     .Cells(1).PasteSpecial xlPasteFormats, , False, False 
     .Cells(1).Select 
     Application.CutCopyMode = False 
     On Error Resume Next 
     .DrawingObjects.Visible = True 
     .DrawingObjects.Delete 
     On Error GoTo 0 
    End With 

    'Publish the sheet to a htm file 
    With TempWB.PublishObjects.Add(_ 
     SourceType:=xlSourceRange, _ 
     Filename:=TempFile, _ 
     Sheet:=TempWB.Sheets(1).Name, _ 
     Source:=TempWB.Sheets(1).UsedRange.Address, _ 
     HtmlType:=xlHtmlStatic) 
     .Publish (True) 
    End With 

    'Read all data from the htm file into RangetoHTML 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
    RangetoHTML = ts.ReadAll 
    ts.Close 
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 
          "align=left x:publishsource=") 

    'Close TempWB 
    TempWB.Close SaveChanges:=False 

    'Delete the htm file we used in this function 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 
End Function

Si j'envoie le courrier électronique à moi-même, le contenu HTML est affiché.

Cependant, si je l'envoyer à tout le monde - cela se produit:

S'il vous plaît quelqu'un peut me montrer où je me trompe?

Source

2017-03-22 user7415328

Cet en-tête est la première chose qui est faux:

Set header = body.CreateHeader("Food Specials Delivery Tracker: The Status of Your Issue Has Changed (" & Range("O" & ActiveCell.Row).Value & ")")

tête champ noms ne peuvent pas contenir des espaces. Lorsque les autres systèmes de messagerie voient cela, ils ne traitent pas cette ligne comme un en-tête. Ils commencent à le traiter, et toutes les lignes qui le suivent, comme un corps de message texte seulement.

Je n'ai pas continué à chercher des erreurs, donc ce n'est peut-être pas le seul.

Source

2017-03-22 19:31:14

merci je vais l'essayer mais comment cela explique l'email html envoyé bien à mon propre email mais le texte quand je l'envoie à un autre email? – user7415328

Parce que vous avez créé le message dans Notes et Notes stocke ces en-têtes en tant qu'éléments individuels, pas avec des lignes de texte dans un flux simple. Il sait que ces éléments sont des éléments d'en-tête. Cela lui permet d'y faire face même si le nom de domaine est techniquement illégal. Au moment où le message arrive à un autre système de messagerie, il a été converti par le routeur Domino en un flux RFC-822 standard, et la conversion conserve ces espaces illégaux, de sorte que le système de messagerie de réception est confus. On peut soutenir que Notes/Domino aurait dû rejeter votre message comme étant illégal, mais ce n'est pas le cas. –

cela a fonctionné grâce – user7415328

C'est la deuxième fois en quelques mois que j'ai vu ce genre de déclaration si compliquée et si compliquée kludgy. Est-ce quelque chose qui est enseigné dans une région ou dans une formation particulière? Je voudrais le réécrire pour le rendre plus facile à lire et à maintenir. Cela peut se faire de deux façons.

Restez avec si-statments:

TrueRef = Ref 
If Ref = "WSM" Then 
    TrueRef = "WES" 
ElseIf Ref = "LUT" Then 
    TrueRef = "MAG" 
ElseIf Ref = "NFL" Then 
    TrueRef = "NOR" 
End If

Ou comme celui-ci:

If Ref = "WSM" Then 
    TrueRef = "WES" 
ElseIf Ref = "LUT" Then 
    TrueRef = "MAG" 
ElseIf Ref = "NFL" Then 
    TrueRef = "NOR" 
Else 
    TrueRef = Ref 
End If

Vous pouvez également utiliser une instruction Select Case:

Select Case Ref 
    Case "WSM" 
     TrueRef = "WES" 
    Case "LUT" 
     TrueRef = "MAG" 
    Case "NFL" 
     TrueRef = "NOR" 
    Case Else 
     TrueRef = Ref 
End Select

Comparez cela avec votre code d'origine :

If Ref = "WED" Then 
TrueRef = "WED" 
Else 
If Ref = "WSM" Then 
TrueRef = "WES" 
Else 
If Ref = "NAY" Then 
TrueRef = "NAY" 
Else 
If Ref = "ENF" Then 
TrueRef = "ENF" 
Else 
If Ref = "LUT" Then 
TrueRef = "MAG" 
Else 
If Ref = "NFL" Then 
TrueRef = "NOR" 
Else 
If Ref = "RUN" Then 
TrueRef = "RUN" 
Else 
If Ref = "SOU" Then 
TrueRef = "SOU" 
Else 
If Ref = "SOU" Then 
TrueRef = "SOU" 
Else 
If Ref = "BRI" Then 
TrueRef = "BRI" 
Else 
If Ref = "LIV" Then 
TrueRef = "LIV" 
Else 
If Ref = "BEL" Then 
TrueRef = "BEL" 
End If 
End If 
End If 
End If 
End If 
End If 
End If 
End If 
End If 
End If 
End If 
End If

Source

2017-03-27 18:24:01

Envoyer un e-mail HTML via IBM Notes à l'aide de VBA?

Répondre

Questions connexes