0
次のコードを使用して、ExcelとIBM Notesを使用してvbaを使用してHTML電子メールを送信しています。VBAを使用してIBM Notes経由でHTML電子メールを送信しますか？
がここに私のコードです：私は自分自身に電子メールを送信する場合
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üß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
、HTMLコンテンツが表示されます。
私は誰にこれを送る場合は、 - これが起こる：
を誰かが私が間違っているつもりですどこ私を見ることができますしてください？
ありがとう、私はそれを試してみるだろうが、これはどのように私は別の電子メールに送信すると自分のメールにテキストがテキストを送信されるhtml電子メールを説明しますか？ – user7415328
Notesでメッセージを作成したため、Notesは単純なストリームのテキスト行ではなく、個々の項目としてこれらのヘッダーを格納します。これらの項目はヘッダ項目であることがわかります。これは、フィールド名が技術的に違法であっても、それを処理することができます。メッセージが他のメールシステムに到達するまでには、Dominoルータによって標準のRFC-822ストリームに変換されており、変換によってこれらの不正なスペースが保持されるため、受信メールシステムは混乱します。ノーツ/ドミノがあなたのメッセージを違法であると拒絶すべきだったのは間違いありませんが、そうではありませんでした。 –
これは感謝しました – user7415328