I am trying to address a list of clients by their name when I send them meeting invitations. Clients must not see other invitees. I have tried several approaches: add clients one-by-one as a Resource, changing meeting notes text each time, forwarding the meeting as an iCalendar item, no luck.
Objective:
Simulate the Forward behavior of an Outlook Meeting.
Change all attendees from Required to Resource(I can do this)
I have done a lot of research and could not find a way to forward a meeting that simulates the user interface version.
Background information:
I have created a Zoom meetings appointment of which I know the location URL
I can successfully access this appointment as an Outlook.AppointmentItem using Restrict
I cannot add the list of clients directly as Resource because then I cannot customize each invite
I cannot use AppointmentItem.ForwardAsVcal as that forwards the meeting as an attachment and does not occupy calendar space for the client (also I believe it looks unprofessional)
I have failed to use MeetingItem.Forward because my object is an Outlook.AppointmentItem
I have successfully added new clients using Recipients.Add and .Type = olResource
I have successfully modified meeting notes using AppointmentItem.GetInspector().WordEditor.Range.FormattedText but this causes previous invites to be canceled and updates text in the invitation so everyone sees the last invite
Code:
Accessing the item successfully
Private Function getMeeting() As Outlook.AppointmentItem
Dim settingsWS As Worksheet
Set settingsWS = ThisWorkbook.Sheets("Settings")
Dim meetingStart As Date, meetingEnd As Date
meetingStart = settingsWS.Cells(2, 1).Value 'start time
Dim locationString As String
locationString = settingsWS.Cells(2, 2).Value 'location url
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim strRestriction As String
daStart = Format(meetingStart, "mm/dd/yyyy hh:mm AMPM")
daEnd = DateAdd("h", 2, daStart)
daEnd = Format(daEnd, "mm/dd/yyyy hh:mm AMPM")
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
strRestriction = strRestriction & " AND [Location] = '" & locationString & "'"
Set oCalendar = GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items.Restrict(strRestriction)
Set getMeeting = oItems(1)
End Function
My failed forwarding trials:
Private Sub sendInvites(oAppt As Outlook.AppointmentItem)
Dim oMail As Outlook.MailItem, oAtt As Outlook.Recipient, embeddedInvitation As OLEObject
Dim industryWS As Worksheet
Set industryWS = ThisWorkbook.ActiveSheet
Dim attendeeRange As Range
Set attendeeRange = industryWS.Cells(3, 1).CurrentRegion 'list of clients
Dim attendeeCompany As String, attendeeEmail As String
Dim attendeeName As String, attendeePrefix As String
Dim attendeeCount As Long, attendeeIndex As Long
attendeeCount = attendeeRange.Rows.Count - 1
For attendeeIndex = 1 To attendeeCount
attendeeCompany = attendeeRange.Cells(attendeeIndex + 1, 1).Value
attendeeEmail = attendeeRange.Cells(attendeeIndex + 1, 2).Value
attendeeName = attendeeRange.Cells(attendeeIndex + 1, 4).Value
attendeePrefix = attendeeRange.Cells(attendeeIndex + 1, 5).Value
Application.StatusBar = "Sending invites (" & CStr(attendeeIndex) & "/" & CStr(attendeeCount) & ") " & attendeeEmail
Set oMail = Outlook.Application.CreateItem(olMailItem)
'Set oMail = oAppt.ForwardAsVcal
oMail.To = attendeeEmail
oMail.BodyFormat = olFormatHTML
oMail.HTMLBody = getInvitationBody(attendeeName, attendeePrefix) & oMail.HTMLBody 'return invitation mailbody as HTML
'Dim fsd As MeetingItem
'fsd.Forward
'Set oAtt = oAppt.Recipients.Add(attendeeEmail)
'oAtt.Type = olResource
'oAppt.GetInspector().WordEditor.Range.FormattedText.Delete
'oMail.GetInspector().WordEditor.Range.FormattedText.Copy
'oAppt.GetInspector().WordEditor.Range.FormattedText.Paste
'oMail.Close False
'oAppt.ForwardAsVcal
'oAppt.Display
'oAppt.Send
oMail.Send
Application.StatusBar = "Saving invites (" & CStr(attendeeIndex) & "/" & CStr(attendeeCount) & ") " & attendeeEmail
'saveInvite oAppt, industryWS, attendeeRange
DoEvents
Next attendeeIndex
End Sub
I solved it after hours of trying.
My initial instinct was to loop through items in the olFolderCalendar since in the UI we access the meeting forward through the calendar, but objects in the calendar are Outlook.AppointmentItem rather than Outlook.MeetingItem which can be forwarded.
The solution is to send the meeting to yourself (or anyone in your organization) so that a copy of the meeting invitation is in your olFolderSentMail. Items in the olFolderSentMail are Outlook.MeetingItem, which can be forwarded. Unless you send it to someone thou, the meeting will not enter your olFolderSentMail.
We can filter our olFolderSentMail by using Restrict and location (URL) of the meeting. Once we have the Outlook.MeetingItem we can create a new Outlook.MeetingItem by calling MeetingItem.Forward on our existing meeting in our olFolderSentMail. Once we have the new Outlook.MeetingItem we can add clients to it as olResource. This will send a customized, otherwise invisible invitation to the client without notifying other clients.
One point of warning before I end this answer: My first approach was to loop in reverse through my olFolderSentMail so as not to loop over to many items and to save time, however keep in mind that everytime you forward the meeting, the new invitation ends up at the top of the olFolderSentMail, so if in reverse, you will be forwarding the forwarded invitation. When using the Restrict approach, you can simply use the first item, which should be your original invitation to yourself.
I am working with an Access application within Access 2016. The application outputs to a PDF file via the DoCmd.OutputTo method.
I want to either send this PDF attached to an email I build in code, or open a new Outlook email with the file attached.
When I click the button in the form which triggers the code that includes my sub(s) (which are located in separate modules), the email window is never displayed nor is an email sent (depending on the use of .Display vs .Send). I also do not receive any errors.
I think it may also be worth noting that the Call to the sub inside of a module that creates the PDF works as expected.
I am running Access 2016 and Outlook 2016 installed as part of Office 2016 Pro Plus on a Windows 7 64-bit machine. The Office suite is 32-bit.
The Module & Sub
(Email Address Redacted)
Dim objEmail As Outlook.MailItem
Dim objApp As Outlook.Application
Set objApp = CreateObject("Outlook.Application")
Set objEmail = oApp.CreateItem(olMailItem)
With objEmail
.Recipients.Add "email#domain.com"
.Subject = "Invoice"
.Body = "See Attached"
.Attachments.Add DestFile
.Display
End With
The Sub Call
MsgBox "Now saving the Invoice as a PDF"
strInvoiceNbr = Int(InvoiceNbr)
strWhere = "[InvoiceNbr]=" & Me!InvoiceNbr
strDocName = "Invoice Print One"
ScrFile = "Invoice Print One"
DestFile = "Inv" + strInvoiceNbr + " - " + Me.GetLastname + " - " + GetLocation
MsgBox DestFile, vbOKOnly
DoCmd.OpenForm strDocName, , , strWhere
Call ExportToPDF(SrcFile, DestFile, "INV")
Call EmailInvoice(DestFile)
Based on the fact that the PDF is being output within a sub in a Module file, should I be creating the email (or calling the sub) within the sub that creates the PDF?
NOTE: I have looked over this accepted answer here on Stack Overflow, as well as many others. My question differs due to the fact that I am asking why the message is not being displayed or sent, not how to build and send a message as the others are.
EDIT:
Outlook does not open and nothing occurs if Outlook is already open.
Final Note:
To add to the accepted answer, in the VBA editor for Access, you will likely have to go to Tools > References and enable Microsoft Outlook 16.0 Object Library or similar based on your version of Office/Outlook.
To pass full path try using Function EmailInvoice
Example
Option Explicit
#Const LateBind = True
Const olFolderInbox As Long = 6
Public Sub ExportToPDF( _
ByVal strSrcFileName As String, _
ByVal strNewFileName As String, _
ByVal strReportType As String _
)
Dim PathFile As String
Dim strEstFolder As String
strEstFolder = "c:\OneDrive\Estimates\"
Dim strInvFolder As String
strInvFolder = "c:\OneDrive\Invoices\"
' Export to Estimates or Invoices Folder based on passed parameter
If strReportType = "EST" Then
DoCmd.OutputTo acOutputForm, strSrcFileName, acFormatPDF, _
strEstFolder & strNewFileName & ".pdf", False, ""
PathFile = strEstFolder & strNewFileName & ".pdf"
ElseIf strReportType = "INV" Then
DoCmd.OutputTo acOutputForm, strSrcFileName, acFormatPDF, _
strInvFolder & strNewFileName & ".pdf", False, ""
PathFile = strEstFolder & strNewFileName & ".pdf"
End If
EmailInvoice PathFile ' call function
End Sub
Public Function EmailInvoice(FldrFilePath As String)
Dim objApp As Object
Set objApp = CreateObject("Outlook.Application")
Dim objNS As Object
Set objNS = olApp.GetNamespace("MAPI")
Dim olFolder As Object
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
'Open inbox to prevent errors with security prompts
olFolder.Display
Dim objEmail As Outlook.MailItem
Set objEmail = oApp.CreateItem(olMailItem)
With objEmail
.Recipients.Add "email#domain.com"
.Subject = "Invoice"
.Body = "See Attached"
.Attachments.Add FldrFilePath
.Display
End With
End Function
Your issue is with probably Outlook security. Normally Outlook would show a popup that says that a 3rd party application is attempting to send email through it. Would you like to allow it or not. However since you are doing this programmatically that popup never appears. There used to be a way to bypass this.
Test your program while the user is logged on and has Outlook open. See if there will be any difference in behavior. If that popup does come up, google the exact message and you will probably find a way to bypass it.
Any reason why you not using sendOject?
The advantage of sendobject, is that you not restriced to Outlook, and any email client should work.
So, this code can be used:
Dim strTo As String
Dim strMessage As String
Dim strSubject As String
strTo = "abc#abc.com;def#def.com"
strSubject = "Your invoice"
strMessage = "Please find the invoice attached"
DoCmd.SendObject acSendReport, "rptInvoice", acFormatPDF, _
strTo, , , strSubject, strMessage
Note that if you need to filter the report, then open it first before you run send object. And of course you close the report after (only required if you had to filter, and open the report before - if no filter is to be supplied, then above code will suffice without having to open the report first).
There is no need to separate write out the pdf file, and no need to write code to attach the resulting pdf. The above does everything in one step, and is effectively one line of code.
Case happen:
User From Notes Mail change to Office 365, their email contain Lotus notes link(Document link) which cannot be accessible.
Call rtBody.Appenddoclink(LateInVw, "", "Click to view your attendance today") ,
I put the "NotesView"into the email body which not show up on office 365. May i know office 365 have any way to identify this is notes Client application and try to open the notes application of that view?
Dim tdy As Variant
Sub Initialize()
Print"Agent:Request for LateIn Reason started running at " & DateValue(Now()) & "," + TimeValue(Now())
On Error GoTo errhandler
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim LateInVw As NotesView
Dim LateInDocs As NotesViewEntryCollection
Dim LateEntry As NotesViewEntry
Dim LateDoc As NotesDocument
Dim StaffVw As NotesView, StaffDoc As NotesDocument
Dim AttVw As NotesView, Attdoc As notesdocument
Dim MailDoc As NotesDocument
Dim rtBody As NotesRichTextItem
Set db=ss.Currentdatabase
Set LateInVw=db.getview("($Today Not Alerted Late-In Time Records)")
Set StaffVw=db.getview("($Active Staff by ID)")
Set AttVw = db.Getview("($Effective Attendance Setting By ID)")
tdy=Datevalue(Now)
'get all time records for today
Set LateInDocs=LateInVw.Allentries
Set lateEntry=LateInDocs.getfirstentry
Do While Not LateEntry Is Nothing
Set LateDoc=LateEntry.Document
Set Attdoc=Attvw.Getdocumentbykey(LateDoc.TStaffID(0), True)
If Attdoc.LateAtt(0)="Yes" Then
If Not ApprovedLateIn(LateDoc, LateDoc.TAmend(0), False) Then
'get staff mail
Set staffDoc=StaffVw.Getdocumentbykey(LateDoc.TStaffID(0), True)
If Not staffdoc Is Nothing Then
'send email with link to main menu
email$=staffDoc.email(0)
Set Maildoc=New NotesDocument(db)
maildoc.Sendto=email$
maildoc.Subject="Smartcard Attendance System: Late-In Notification for " +Format$(LateDoc.TDate(0),"dd/mm/yyyy")
Set rtBody=New NotesRichTextItem(maildoc, "Body")
Call rtBody.appendtext(" Dear"+" "+ staffDoc.StaffName(0)+",")
Call rtBody.AddNewline(2)
Call rtBody.appendtext("You clocked in to work today at "+lateDoc.TAmend(0)+". Please click on the link below to submit your reason for the late attendance. Thank You!")
Call rtBody.Addnewline(1)
Call rtBody.Appenddoclink(LateInVw, "", "Click to view your attendance today")
Call rtBody.Addnewline(2)
Call rtBody.Appendtext("***If the box to key in the late-in reason does not appear, kindly use the 'History Attendance' to key-in instead.")
maildoc.send(False)
End If
End If
'End If 'check late-in on/off in attendance settings
LateDoc.LateInAlert="Send"
Call LateDoc.save(True,False)
End If 'check late-in on/off in attendance settings
Set LateEntry=LateInDocs.Getnextentry(LateEntry)
Loop
Print"Agent:Request for LateIn Reason ended running at " & DateValue(Now()) & "," + TimeValue(Now())
Exit Sub
errhandler:
Print "Got error " & Error$ & " on line " & CStr(Erl)
Resume next
Print"Agent:Request for LateIn Reason ended running at " & DateValue(Now()) & "," + TimeValue(Now())
End Sub
This is my sample rewrite code as Mime format...
Sub Initialize
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim vw As NotesView
'Dim Doc As NotesViewEntryCollection
Dim LateInVw As NotesView
Dim Ec As NotesViewEntryCollection
Dim Entry As NotesViewEntry
Dim Doc As NotesDocument
Dim MailDoc As NotesDocument
Dim rtBody As NotesRichTextItem
Set db=ss.Currentdatabase
Set vw=db.getview("(test send mail)")
tdy=DateValue(Now)
%Rem
Set replydoc = db.Createdocument()
Call replydoc.Replaceitemvalue("Form", "Memo")
Call replydoc.Replaceitemvalue("Subject", "Pre-check Passed - " + apptitle)
Call replydoc.Replaceitemvalue("SendTo", indoc.From(0))
Call replydoc.Replaceitemvalue("BlindCopyTo", mailinadd)
Set body = replydoc.Createmimeentity
%End Rem
Set EC = vw.Allentries
Set Entry=Ec.getfirstentry
Do While Not Entry Is Nothing
Set Doc = Entry.Document
email$="chee111385#gmail.com"
Set Maildoc= db.Createdocument()
Call Maildoc.Replaceitemvalue("Form", "Memo")
Call Maildoc.Replaceitemvalue("Subject", "Test Send Mail, Mime Format")
Call Maildoc.Replaceitemvalue("SendTo",email$)
Set body = Maildoc.Createmimeentity
ss.Convertmime = False
Set stream = ss.Createstream()
stream.Writetext(|<html><body>|)
stream.Writetext(|<p>Dear Sir, | + |,</p>|)
stream.Writetext(|<p>This is a testing mail. Thanks You!<br>| + |</p>|)
stream.Writetext(|<p>|+|Notes://Mulu/482577AE00260EC5/|+ +Doc.Universalid+|</p>|)
Call stream.Writetext(|</body></html>|)
Call body.Setcontentfromtext(stream, "text/html;charset=UTF-8", 1725)
Call maildoc.Send(False)
ss.Convertmime = True
Set Entry = EC.Getnextentry(Entry)
Loop
End Sub
I not sure how to just open notes document directly...as everytime i click the link it go to the frameset itself...which is not correct!
If you're asking about just this one application, then what you need to do is learn about notes:// URLs, which you can read about here. You just need to change your code to generate a correctly formatted URL for the view, either instead of or in addition to the doclink. When the user clicks the notes:// URL, the Notes client will open and take the user to the view.
If, however, you actually have lots of applications that send doclinks to users, than you may want to look for a solution that installs on your Domino server and handles this automatically for all the applications without you having to change any code. A company called Genii Software has a product called CoExLinks Fidelity that does this.
I'm trying to automate the sending of an email through Lotus Notes 9.0 using VBA. The code will load up notes, which asks for my password but before the password prompt shows up, I get an error. The error I run in to is "Run-time error '-2147417851 (80010105)': Automation Error The server threw an exception" When I hit debug, the line that it fails on is "Set obDoc = obDB.CreateDocument". A lot of what I've seen online example wise matches what I'm doing in my code, so I'm not sure where the problem is.
Here's the code:
Sub Send_Emails()
Dim stSubject As Variant
Dim emailList As Variant
Dim obSess As Object
Dim obDB As Object
Dim obDoc As Object
'----Create Email List - separate function, dynamically creates email list based off report processing done in other functions
CreateEmailList
'----Info for Subject
stSubject = "test subject"
'----Create Notes Session
Set obSess = CreateObject("Notes.NotesSession")
Set obDB = obSess.GETDATABASE("", "")
If obDB.IsOpen = False Then
Call obDB.OPENMAIL
End If
'----Create the e-mail - **FAILURE OCCURS HERE**
Set obDoc = obDB.CreateDocument
'----Add values to the email
With obDoc
.form = "Memo"
.SendTo = "test#test.com"
.blindcopyTo = emailList
.Subject = stSubject
.HTMLBody = "<HTML><BODY><p>test</p></BODY></HTML>"
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, emailList
End With
'----Clean Up
Set obDoc = Nothing
Set obDB = Nothing
Set obSess = Nothing
MsgBox "The e-mail has been sent successfully", vbInformation
End Sub
You mention that you are using Notes 9, so I looked at the online help for Notes 9.01 and the help page for the OpenMail method says
Note: This method is supported in LotusScript® only. For COM, use OpenMailDatabase in NotesDbDirectory.
Now, you're actually using the OLE automation classes (rooted at Notes.NotesSession), not the COM classes (rooted at Lotus.NotesSession), so I don't know if you can use the NotesDbDirectory class or not, but the other way of opening the current user's mail database would be to call NotesSession.GetEnvironmentString("MailServer",true) and NotesSession.GetEnvironmentString("MailFile",true), and use those as the values for your call to GetDatabase.
I am writing a VBA script in Access that creates and auto-populates a few dozen emails. It's been smooth coding so far, but I'm new to Outlook. After creating the mailitem object, how do I add the default signature to the email?
This would be the default signature that is automatically added when creating a new email.
Ideally, I'd like to just use ObjMail.GetDefaultSignature, but I can't find anything like it.
Currently, I'm using the function below (found elsewhere on the internet) and referencing the exact path & filename of the htm file. But this will be used by several people and they may have a different name for their default htm signature file. So this works, but it's not ideal:
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
(Called with getboiler(SigString = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Mysig.txt"))
Edit
Thanks to JP (see comments), I realize that the default signature is showing up at first, but it disappears when I use HTMLBody to add a table to the email. So I guess my question is now: How do I display the default signature and still display an html table?
Sub X()
Dim OlApp As Outlook.Application
Dim ObjMail As Outlook.MailItem
Set OlApp = Outlook.Application
Set ObjMail = OlApp.CreateItem(olMailItem)
ObjMail.BodyFormat = olFormatHTML
ObjMail.Subject = "Subject goes here"
ObjMail.Recipients.Add "Email goes here"
ObjMail.HTMLBody = ObjMail.Body & "HTML Table goes here"
ObjMail.Display
End Sub
The code below will create an outlook message & keep the auto signature
Dim OApp As Object, OMail As Object, signature As String
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.Display
End With
signature = OMail.body
With OMail
'.To = "someone#somedomain.com"
'.Subject = "Type your email subject here"
'.Attachments.Add
.body = "Add body text here" & vbNewLine & signature
'.Send
End With
Set OMail = Nothing
Set OApp = Nothing
My solution is to display an empty message first (with default signature!) and insert the intended strHTMLBody into the existing HTMLBody.
If, like PowerUser states, the signature is wiped out while editing HTMLBody you might consider storing the contents of ObjMail.HTMLBody into variable strTemp immediately after ObjMail.Display and add strTemp afterwards but that should not be necessary.
Sub X(strTo as string, strSubject as string, strHTMLBody as string)
Dim OlApp As Outlook.Application
Dim ObjMail As Outlook.MailItem
Set OlApp = Outlook.Application
Set ObjMail = OlApp.CreateItem(olMailItem)
ObjMail.To = strTo
ObjMail.Subject = strSubject
ObjMail.Display
'You now have the default signature within ObjMail.HTMLBody.
'Add this after adding strHTMLBody
ObjMail.HTMLBody = strHTMLBody & ObjMail.HTMLBody
'ObjMail.Send 'send immediately or
'ObjMail.close olSave 'save as draft
'Set OlApp = Nothing
End sub
Dim OutApp As Object, OutMail As Object, LogFile As String
Dim cell As Range, S As String, WMBody As String, lFile As Long
S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll
WMBody = "<br>Hi All,<br><br>" & _
"Last line,<br><br>" & S 'Add the Signature to end of HTML Body
Just thought I'd share how I achieve this. Not too sure if it's correct in the defining variables sense but it's small and easy to read which is what I like.
I attach WMBody to .HTMLBody within the object Outlook.Application OLE.
Hope it helps someone.
Thanks,
Wes.
I figured out a way, but it may be too sloppy for most. I've got a simple Db and I want it to be able to generate emails for me, so here's the down and dirty solution I used:
I found that the beginning of the body text is the only place I see the "<div class=WordSection1>" in the HTMLBody of a new email, so I just did a simple replace, replacing
"<div class=WordSection1><p class=MsoNormal><o:p>"
with
"<div class=WordSection1><p class=MsoNormal><o:p>" & sBody
where sBody is the body content I want inserted. Seems to work so far.
.HTMLBody = Replace(oEmail.HTMLBody, "<div class=WordSection1><p class=MsoNormal><o:p>", "<div class=WordSection1><p class=MsoNormal><o:p>" & sBody)
I constructed this approach while looking for how to send a message on a recurring schedule.
I found the approach where you reference the Inspector property of the created message did not add the signature I wanted (I have more than one account set up in Outlook, with separate signatures.)
The approach below is fairly flexible and still simple.
Private Sub Add_Signature(ByVal addy as String, ByVal subj as String, ByVal body as String)
Dim oMsg As MailItem
Set oMsg = Application.CreateItem(olMailItem)
oMsg.To = addy
oMsg.Subject = subj
oMsg.Body = body
Dim sig As String
' Mysig is the name you gave your signature in the OL Options dialog
sig = ReadSignature("Mysig.htm")
oMsg.HTMLBody = Item.Body & "<p><BR/><BR/></p>" & sig ' oMsg.HTMLBody
oMsg.Send
Set oMsg = Nothing
End Sub
Private Function ReadSignature(sigName As String) As String
Dim oFSO, oTextStream, oSig As Object
Dim appDataDir, sig, sigPath, fileName As String
appDataDir = Environ("APPDATA") & "\Microsoft\Signatures"
sigPath = appDataDir & "\" & sigName
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oTextStream = oFSO.OpenTextFile(sigPath)
sig = oTextStream.ReadAll
' fix relative references to images, etc. in sig
' by making them absolute paths, OL will find the image
fileName = Replace(sigName, ".htm", "") & "_files/"
sig = Replace(sig, fileName, appDataDir & "\" & fileName)
ReadSignature = sig
End Function
I have made this a Community Wiki answer because I could not have created it without PowerUser's research and the help in earlier comments.
I took PowerUser's Sub X and added
Debug.Print "n------" 'with different values for n
Debug.Print ObjMail.HTMLBody
after every statement. From this I discovered the signature is not within .HTMLBody until after ObjMail.Display and then only if I haven't added anything to the body.
I went back to PowerUser's earlier solution that used C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Mysig.txt"). PowerUser was unhappy with this because he wanted his solution to work for others who would have different signatures.
My signature is in the same folder and I cannot find any option to change this folder. I have only one signature so by reading the only HTM file in this folder, I obtained my only/default signature.
I created an HTML table and inserted it into the signature immediately following the <body> element and set the html body to the result. I sent the email to myself and the result was perfectly acceptable providing you like my formatting which I included to check that I could.
My modified subroutine is:
Sub X()
Dim OlApp As Outlook.Application
Dim ObjMail As Outlook.MailItem
Dim BodyHtml As String
Dim DirSig As String
Dim FileNameHTMSig As String
Dim Pos1 As Long
Dim Pos2 As Long
Dim SigHtm As String
DirSig = "C:\Users\" & Environ("username") & _
"\AppData\Roaming\Microsoft\Signatures"
FileNameHTMSig = Dir$(DirSig & "\*.htm")
' Code to handle there being no htm signature or there being more than one
SigHtm = GetBoiler(DirSig & "\" & FileNameHTMSig)
Pos1 = InStr(1, LCase(SigHtm), "<body")
' Code to handle there being no body
Pos2 = InStr(Pos1, LCase(SigHtm), ">")
' Code to handle there being no closing > for the body element
BodyHtml = "<table border=0 width=""100%"" style=""Color: #0000FF""" & _
" bgColor=#F0F0F0><tr><td align= ""center"">HTML table</td>" & _
"</tr></table><br>"
BodyHtml = Mid(SigHtm, 1, Pos2 + 1) & BodyHtml & Mid(SigHtm, Pos2 + 2)
Set OlApp = Outlook.Application
Set ObjMail = OlApp.CreateItem(olMailItem)
ObjMail.BodyFormat = olFormatHTML
ObjMail.Subject = "Subject goes here"
ObjMail.Recipients.Add "my email address"
ObjMail.Display
End Sub
Since both PowerUser and I have found our signatures in C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures I suggest this is the standard location for any Outlook installation. Can this default be changed? I cannot find anything to suggest it can. The above code clearly needs some development but it does achieve PowerUser's objective of creating an email body containing an HTML table above a signature.
I need 50 rep to post a comment against the Signature Option I found most helpful, however I had an issue with images not showing correctly so I had to find a work around. This is my solution:
Using #Morris Maynard's answer as a base https://stackoverflow.com/a/18455148/2337102 I then had to go through the following:
Notes:
Back up your .htm file before starting, copy & paste to a secondary folder
You will be working with both the SignatureName.htm and the SignatureName_files Folder
You do not need HTML experience, the files will open in an editing program such as Notepad or Notepad++ or your specified HTML Program
Navigate to your Signature File location (standard should be C:\Users\"username"\AppData\Roaming\Microsoft\Signatures)
Open the SignatureName.htm file in a text/htm editor (right click on the file, "Edit with Program")
Use Ctrl+F and enter .png; .jpg or if you don't know your image type, use image001
You will see something like: src="signaturename_files/image001.png"
You need to change that to the whole address of the image location
C:\Users\YourName\AppData\Roaming\Microsoft\Signatures\SignatureNameFolder_files\image001
or
src="E:\location\Signatures\SignatureNameFolder_files\image001.png"
Save your file (overwrite it, you had of course backed up the original)
Return to Outlook and Open New Mail Item, add your signature. I received a warning that the files had been changed, I clicked ok, I needed to do this twice, then once in the "Edit Signatures Menu".
Some of the files in this webpage aren't in the expected location. Do you want to download them anyway? If you're sure the Web page is from a trusted source, click Yes."
Run your Macro event, the images should now be showing.
Credit
MrExcel - VBA code signature code failure: http://bit.ly/1gap9jY
Most of the other answers are simply concatenating their HTML body with the HTML signature. However, this does not work with images, and it turns out there is a more "standard" way of doing this.1
Microsoft Outlook pre-2007 which is configured with WordEditor as its editor, and Microsoft Outlook 2007 and beyond, use a slightly cut-down version of the Word Editor to edit emails. This means we can use the Microsoft Word Document Object Model to make changes to the email.
Set objMsg = Application.CreateItem(olMailItem)
objMsg.GetInspector.Display 'Displaying an empty email will populate the default signature
Set objSigDoc = objMsg.GetInspector.WordEditor
Set objSel = objSigDoc.Windows(1).Selection
With objSel
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdStory, 1
.Copy 'This will copy the signature
End With
objMsg.HTMLBody = "<p>OUR HTML STUFF HERE</p>"
With objSel
.Move WdUnits.wdStory, 1 'Move to the end of our new message
.PasteAndFormat wdFormatOriginalFormatting 'Paste the copied signature
End With
'I am not a VB programmer, wrote this originally in another language so if it does not
'compile it is because this is my first VB method :P
Microsoft Outlook 2007 Programming (S. Mosher)> Chapter 17, Working with Item Bodies: Working with Outlook Signatures
I like Mozzi's answer but found that it did not retain the default fonts that are user specific. The text all appeared in a system font as normal text. The code below retains the user's favourite fonts, while making it only a little longer. It is based on Mozzi's approach, uses a regular expression to replace the default body text and places the user's chosen Body text where it belongs by using GetInspector.WordEditor. I found that the call to GetInspector did not populate the HTMLbody as dimitry streblechenko says above in this thread, at least, not in Office 2010, so the object is still displayed in my code. In passing, please note that it is important that the MailItem is created as an Object, not as a straightforward MailItem - see here for more. (Oh, and sorry to those of different tastes, but I prefer longer descriptive variable names so that I can find routines!)
Public Function GetSignedMailItemAsObject(ByVal ToAddress As String, _
ByVal Subject As String, _
ByVal Body As String, _
SignatureName As String) As Object
'================================================================================================================='Creates a new MailItem in HTML format as an Object.
'Body, if provided, replaces all text in the default message.
'A Signature is appended at the end of the message.
'If SignatureName is invalid any existing default signature is left in place.
'=================================================================================================================
' REQUIRED REFERENCES
' VBScript regular expressions (5.5)
' Microsoft Scripting Runtime
'=================================================================================================================
Dim OlM As Object 'Do not define this as Outlook.MailItem. If you do, some things will work and some won't (i.e. SendUsingAccount)
Dim Signature As String
Dim Doc As Word.Document
Dim Regex As New VBScript_RegExp_55.RegExp '(can also use use Object if VBScript is not Referenced)
Set OlM = Application.CreateItem(olMailItem)
With OlM
.To = ToAddress
.Subject = Subject
'SignatureName is the exactname that you gave your signature in the Message>Insert>Signature Dialog
Signature = GetSignature(SignatureName)
If Signature <> vbNullString Then
' Should really strip the terminal </body tag out of signature by removing all characters from the start of the tag
' but Outlook seems to handle this OK if you don't bother.
.Display 'Needed. Without it, there is no existing HTMLbody available to work with.
Set Doc = OlM.GetInspector.WordEditor 'Get any existing body with the WordEditor and delete all of it
Doc.Range(Doc.Content.Start, Doc.Content.End) = vbNullString 'Delete all existing content - we don't want any default signature
'Preserve all local email formatting by placing any new body text, followed by the Signature, into the empty HTMLbody.
With Regex
.IgnoreCase = True 'Case insensitive
.Global = False 'Regex finds only the first match
.MultiLine = True 'In case there are stray EndOfLines (there shouldn't be in HTML but Word exports of HTML can be dire)
.Pattern = "(<body.*)(?=<\/body)" 'Look for the whole HTMLbody but do NOT include the terminal </body tag in the value returned
OlM.HTMLbody = .Replace(OlM.HTMLbody, "$1" & Signature)
End With ' Regex
Doc.Range(Doc.Content.Start, Doc.Content.Start) = Body 'Place the required Body before the signature (it will get the default style)
.Close olSave 'Close the Displayed MailItem (actually Object) and Save it. If it is left open some later updates may fail.
End If ' Signature <> vbNullString
End With ' OlM
Set GetSignedMailItemAsObject = OlM
End Function
Private Function GetSignature(sigName As String) As String
Dim oTextStream As Scripting.TextStream
Dim oSig As Object
Dim appDataDir, Signature, sigPath, fileName As String
Dim FileSys As Scripting.FileSystemObject 'Requires Microsoft Scripting Runtime to be available
appDataDir = Environ("APPDATA") & "\Microsoft\Signatures"
sigPath = appDataDir & "\" & sigName & ".htm"
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set oTextStream = FileSys.OpenTextFile(sigPath)
Signature = oTextStream.ReadAll
' fix relative references to images, etc. in Signature
' by making them absolute paths, OL will find the image
fileName = Replace(sigName, ".htm", "") & "_files/"
Signature = Replace(Signature, fileName, appDataDir & "\" & fileName)
GetSignature = Signature
End Function
The existing answers had a few problems for me:
I needed to insert text (e.g. 'Good Day John Doe') with html formatting where you would normally type your message.
At least on my machine, Outlook adds 2 blank lines above the signature where you should start typing. These should obviously be removed (replaced with custom HTML).
The code below does the job. Please note the following:
The 'From' parameter allows you to choose the account (since there could be different default signatures for different email accounts)
The 'Recipients' parameter expects an array of emails, and it will 'Resolve' the added email (i.e. find it in contacts, as if you had typed it in the 'To' box)
Late binding is used, so no references are required
'Opens an outlook email with the provided email body and default signature
'Parameters:
' from: Email address of Account to send from. Wildcards are supported e.g. *#example.com
' recipients: Array of recipients. Recipient can be a Contact name or email address
' subject: Email subject
' htmlBody: Html formatted body to insert before signature (just body markup, should not contain html, head or body tags)
Public Sub CreateMail(from As String, recipients, subject As String, htmlBody As String)
Dim oApp, oAcc As Object
Set oApp = CreateObject("Outlook.application")
With oApp.CreateItem(0) 'olMailItem = 0
'Ensure we are sending with the correct account (to insert the correct signature)
'oAcc is of type Outlook.Account, which has other properties that could be filtered with if required
'SmtpAddress is usually equal to the raw email address
.SendUsingAccount = Nothing
For Each oAcc In oApp.Session.Accounts
If CStr(oAcc.SmtpAddress) = from Or CStr(oAcc.SmtpAddress) Like from Then
Set .SendUsingAccount = oAcc
End If
Next oAcc
If .SendUsingAccount Is Nothing Then Err.Raise -1, , "Unknown email account " & from
For Each addr In recipients
With .recipients.Add(addr)
'This will resolve the recipient as if you had typed the name/email and pressed Tab/Enter
.Resolve
End With
Next addr
.subject = subject
.Display 'HTMLBody is only populated after this line
'Remove blank lines at the top of the body
.htmlBody = Replace(.htmlBody, "<o:p> </o:p>", "")
'Insert the html at the start of the 'body' tag
Dim bodyTagEnd As Long: bodyTagEnd = InStr(InStr(1, .htmlBody, "<body"), .htmlBody, ">")
.htmlBody = Left(.htmlBody, bodyTagEnd) & htmlBody & Right(.htmlBody, Len(.htmlBody) - bodyTagEnd)
End With
Set oApp = Nothing
End Sub
Use as follows:
CreateMail from:="*#contoso.com", _
recipients:= Array("john.doe#contoso.com", "Jane Doe", "unknown#example.com"), _
subject:= "Test Email", _
htmlBody:= "<p>Good Day All</p><p>Hello <b>World!</b></p>"
Result:
Often this question is asked in the context of Ron de Bruin's RangeToHTML function, which creates an HTML PublishObject from an Excel.Range, extracts that via FSO, and inserts the resulting stream HTML in to the email's HTMLBody. In doing so, this removes the default signature (the RangeToHTML function has a helper function GetBoiler which attempts to insert the default signature).
Unfortunately, the poorly-documented Application.CommandBars method is not available via Outlook:
wdDoc.Application.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
It will raise a runtime 6158:
But we can still leverage the Word.Document which is accessible via the MailItem.GetInspector method, we can do something like this to copy & paste the selection from Excel to the Outlook email body, preserving your default signature (if there is one).
Dim rng as Range
Set rng = Range("A1:F10") 'Modify as needed
With OutMail
.To = "xxxxx#xxxxx.com"
.BCC = ""
.Subject = "Subject"
.Display
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
End With
Note that in some cases this may not perfectly preserve the column widths or in some instances the row heights, and while it will also copy shapes and other objects in the Excel range, this may also cause some funky alignment issues, but for simple tables and Excel ranges, it is very good:
Need to add a reference to Microsoft.Outlook. it is in Project references, from the visual basic window top menu.
Private Sub sendemail_Click()
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.Display
.To = email
.Subject = "subject"
Dim wdDoc As Object ' Word.Document
Dim wdRange As Object ' Word.Range
Set wdDoc = .GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0) ' Create Range at character position 0 with length of 0 character s.
' if you need rtl:
wdRange.Paragraphs.ReadingOrder = 0 ' 0 is rtl , 1 is ltr
wdRange.InsertAfter "mytext"
End With
End Sub
Assuming that your signature has this line "Thank you."
Now all you need to do is to replace "Thank you." with whatever you want. Note: This is case sensitive so you must use the exact case. "Thank you" is not as "Thank You"
myMail.HTMLBody = Replace(myMail.HTMLBody, "Thank you.", "Please find attached the file you needed. Thank You.")
Here's the full code:
Sub Emailer()
'Assumes your signature has this line: "Thank you."
Set outlookApp = New Outlook.Application
Set myMail = outlookApp.CreateItem(olMailItem)
myMail.To = "x#x.com"
myMail.Subject = "Hello"
myMail.Display
myMail.HTMLBody = Replace(myMail.HTMLBody, "Thank you.", "Please find attached the file you needed. Thank You.")
'myMail.Send
End Sub
Outlook adds the signature to the new unmodified messages (you should not modify the body prior to that) when you call MailItem.Display (which causes the message to be displayed on the screen) or when you access the MailItem.GetInspector property (in the older versions of Outlook prior to 2016) - you do not have to do anything with the returned Inspector object, but Outlook will populate the message body with the signature.
Once the signature is added, read the HTMLBody property and merge it with the HTML string that you are trying to set. Note that you cannot simply concatenate 2 HTML strings - the strings need to be merged. E.g. if you want to insert your string at the top of the HTML body, look for the "<body" substring, then find the next occurrence of ">" (this takes care of the <body> element with attributes), then insert your HTML string after that ">".
Outlook Object Model does not expose signatures at all.
On a general note, the name of the signature is stored in the account profile data accessible through the IOlkAccountManager Extended MAPI interface. Since that interface is Extended MAPI, it can only be accessed using C++ or Delphi. You can see the interface and its data in OutlookSpy (I am its author) if you click the IOlkAccountManager button.
Once you have the signature name, you can read the HTML file from the file system (keep in mind that the folder name (Signatures in English) is localized.
Also keep in mind that if the signature contains images, they must also be added to the message as attachments and the <img> tags in the signature/message body adjusted to point the src attribute to the attachments rather than a subfolder of the Signatures folder where the images are stored.
It will also be your responsibility to merge the HTML styles from the signature HTML file with the styles of the message itself.
If using Redemption (I am its author) is an option, you can use its RDOAccount object - it exposes ReplySignature and NewMessageSignature properties.
Redemption also exposes RDOSignature.ApplyTo method that takes a pointer to the RDOMail object and inserts the signature at the specified location correctly merging the images and the styles:
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set Drafts = Session.GetDefaultFolder(olFolderDrafts)
set Msg = Drafts.Items.Add
Msg.To = "user#domain.demo"
Msg.Subject = "testing signatures"
Msg.HTMLBody = "<html><body>some <b>bold</b> message text</body></html>"
set Account = Session.Accounts.GetOrder(2).Item(1) 'first mail account
if Not (Account Is Nothing) Then
set Signature = Account.NewMessageSignature
if Not (Signature Is Nothing) Then
Signature.ApplyTo Msg, false 'apply at the bottom
End If
End If
Msg.Send
Previously MailItem.GetInspector was a valid replacement for MailItem.Display.
This solution was lost. "Outlook adds the signature to the new unmodified messages (you should not modify the body prior to that) when you call MailItem.Display (which causes the message to be displayed on the screen) or when you access the MailItem.GetInspector property (in the older versions of Outlook prior to 2016) - you do not have to do anything with the returned Inspector object, but Outlook will populate the message body with the signature."
.GetInspector can be implemented differently:
Option Explicit
Sub GenerateSignatureWithoutDisplay()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.mailItem
Set objOutlook = Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.subject = "Test email to generate signature without .Display"
' To get the signature
' .GetInspector ' Previously a direct replacement for .Display
' Later this no longer generated the signature.
' No error so solution assumed to be lost.
' 2022-06-22 Compile error: Invalid use of property
' 2022-06-22 Germ of the idea seen here
' https://stackoverflow.com/questions/72692114
' Dim signature As Variant ' The lucky trick to declare as Variant
' signature = .GetInspector
' signature = .HtmlBody
' .HtmlBody = "Input variable information here" & "<br><br>" & signature
' After review of the documentation
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim myInspector As Outlook.Inspector
Set myInspector = .GetInspector
.HtmlBody = "Input variable information here" & "<br><br>" & .HtmlBody
.Close olSave
End With
' To verify after the save the signature is in saved mail
'objMail.Display
End Sub