How to avoid the Outlook security warning for email automation? - excel

I'm trying to send an Outlook email from Excel 2010 using VBA.
Most answers on Stack Overflow don't seem to have a method of using VBA to avoid the Outlook security warning, nor for Outlook/Excel 2010.
Do any free methods exist? The Redemption method won't be a viable option, unless it is easy to install on 10 machines in a large company.
How I send emails:
Dim emailAddr As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "xxxx#xxxx.edu"
.Subject = "Demande"
.HtmlBody = CombinedValueHtml
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub

This is a partial answer. I have made it a Community Wiki answer in the expectation that someone else can explain the final part which I cannot get to work.
This web page, http://msdn.microsoft.com/en-us/library/office/aa155754(v=office.10).aspx , explains the first three parts of the process. It was written in 1999 so cannot be followed exactly because it refers to old versions of Windows and Office.
The first step is to add Digital Signature for VBA Projects to your Office installation although I found it under Shared Tools rather than Office Tools. Don't make the mistake of just adding Digital Signature for VBA Projects to Outlook because, as I discovered, that means you uninstall Word, Excel, etc.
The second step is to run Selfcert.exe to create a digital certificate in your own name.
The third step is to open Outlook's VBA editor, select Tools then Digital Certificate then Choose to sign the project with your certificate.
With these steps you can suppress the warning that Outlook contains macros but this does not suppress that warning that a macro is accessing emails. To suppress that warning, you need a fourth step which is to place your certificate within the Trusted Root Certificate Authorities Store. This web page http://technet.microsoft.com/en-us/library/cc962065.aspx explains about the Certification Authority Trust Model but I cannot successfully use Microsoft Management Console to achieve the fourth step.

Instead .send use the following:
.Display 'displays outlook email
Application.SendKeys "%s" 'presses send as a send key
note: be careful when using display keys, if you move the mouse and click while the program is running it can change whats going on. also outlook will display on ur screen and send.. if you working on something else's and this bothers you, yea.. not the best idea

The Redemption method won't be a viable option, unless it is easy to
install on 10 machines inside of a large company.
You can use RedemptionLoader (I am its author) - it loads the dll directly and does no require the dll to be installed using the registry.
It is either Extended MAPI in C++ or Delphi, Redemption (I am its author - wraps Extended MAPI and can be used form any language) or a utility like ClickYes.

If you don't send the message immediately but just display it and let the user do modifications (if any) and let them press the send button theirselves, this would work:
i.e. use
.Display
instead of
.Send

I explained how you can use vba to send emails in this answer You will find a macro that I use extensively in my daily work.
Following recomendations from #Floern, here is the explanation:
In order to insert images (signature as images) you could use the following code:
Step 1. Copy this code an paste in class module and name that class module like "MailOptions"
Private Message As CDO.Message
Private Attachment, Expression, Matches, FilenameMatch, i
Public Sub PrepareMessageWithEmbeddedImages(ByVal FromAddress, ByVal ToAddress, ByVal Subject, ByVal HtmlContent)
Set Expression = CreateObject("VBScript.RegExp")
Expression.Pattern = "\<EMBEDDEDIMAGE\:(.+?)\>"
Expression.IgnoreCase = True
Expression.Global = False 'one match at a time
Set Message = New CDO.Message
Message.From = FromAddress
Message.To = ToAddress
Message.Subject = Subject
'Find matches in email body, incrementally increasing the auto-assigned attachment identifiers
i = 1
While Expression.Test(HtmlContent)
FilenameMatch = Expression.Execute(HtmlContent).Item(0).SubMatches(0)
Set Attachment = Message.AddAttachment(FilenameMatch)
Attachment.Fields.Item("urn:schemas:mailheader:Content-ID") = "<attachedimage" & i & ">" ' set an ID we can refer to in HTML
Attachment.Fields.Item("urn:schemas:mailheader:Content-Disposition") = "inline" ' "hide" the attachment
Attachment.Fields.Update
HtmlContent = Expression.Replace(HtmlContent, "cid:attachedimage" & i) ' update the HTML to refer to the actual attachment
i = i + 1
Wend
Message.HTMLBody = HtmlContent
End Sub
Public Sub SendMessageBySMTP(ByVal SmtpServer, ByVal SmtpUsername, ByVal SmtpPassword, ByVal UseSSL)
Dim Configuration
Set Configuration = CreateObject("CDO.Configuration")
Configuration.Load -1 ' CDO Source Defaults
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SmtpServer
'Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SmtpPort
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
If SmtpUsername <> "" Then
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SmtpUsername
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SmtpPassword
End If
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = UseSSL
Configuration.Fields.Update
Set Message.Configuration = Configuration
Message.Send
End Sub
Step 2. In an standar module you will elaborate your .html content and instantiate a object from the class:
public sub send_mail()
Dim signature As String
dim mail_sender as new MailOptions 'here you are instantiating an object from the class module created previously
dim content as string
signature = "C:\Users\your_user\Documents\your_signature.png"
content = "<font face=""verdana"" color=""black"">This is some text!</font>"
content = content & "<img src=""<EMBEDDEDIMAGE:" & signature & " >"" />"
mail_sender.PrepareMessageWithEmbeddedImages _
FromAddress:="chrism_mail#blablabla.com", _
ToAddress:="addressee_mail#blablabla.com", _
Subject:="your_subject", _
HtmlContent:=content
'your_Smtp_Server, for example: RelayServer.Contoso.com
correos.SendMessageBySMTP "your_Smtp_Server", "your_network_user_account", "your_network_user_account_password", False
end sub

Related

How to write a vba macro that copies and paste excel range into a new outlook email with text and signature? [duplicate]

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

Select Data Risk classification as internal automatically

I am trying to send outlook mail using VBA . Every time I run my macro a pop-up comes to me of TITUS stating as select data risk classification. My question is if there any way I can bypass it or select it automatically and send an email.
I have the attempted code snippets to achieve it from multiple sources from internet below.
Sub test()
Dim AOMSOutlook As Object
Dim AOMailMsg As Object
Set AOMSOutlook = CreateObject("Outlook.Application")
Dim objUserProperty As Object
Set AOMailMsg = AOMSOutlook.CreateItem(0)
Set objUserProperty = AOMailMsg.UserProperties.Add("TITUSAutomatedClassification", 1)
objUserProperty.Value = "TLPropertyRoot=ABCDE;Classification=Internal;Registered to:My Companies;"
With AOMailMsg
.To = "v-fexue#outlook.com"
.Subject = "New Report"
.HTMLBody = "Hi"
.Save
.Send
End With
Set AOMailMsg = Nothing
Set objUserProperty = Nothing
Set AOMSOutlook = Nothing
Set lOMailMsg = Nothing
Set objUserProperty = Nothing
Set lOMSOutlook = Nothing
End Sub
Also please clear if objUserProperty.Value = "TLPropertyRoot=ABCDE;Classification=Internal;Registered to:My Companies; Registered to: (has to be actual company name)
Thanks in advance.
You may contact Titus developers for the actual format of the string that needs to be set to avoid any popups from their add-in in Outlook. Also you may check out the sent items for properties set by the add-in, use any low-level property explorer tool such as MFCMAPI or OutlookSpy for that.

Use VBA to #-Mentions a user in a Threaded Comment in excel

I added a UserForm into my file so comments can be added to a cell (that way I can update the data on other cells when a comment is added and someone is mentioned).
So far I can get the comment entered with no issues. But I can´t find a way to #mention a user so the notification is sent. Does anyone know if this is manageable with VBA?
Range("A1").AddCommentThreaded ("Comment text")
Answer
By reading the documentation the method is not likely implemented in VBA and seems only a front end to Excel, but not visible to VBA itself. The only property that I found was "resolved" (which is not mentioned in the documentation of the object itself), but there is not a way to "resolve" it per say.
VBA does not resolve the user (even if it's correctly written) and most likely there is no native way to do so.
Workaroud
Your only solution would be to implement it by yourself: according to your question, since you are using an UserForm I would append something like this
Add the reference for outlook (you may use late binding, but I rather to add the references as it is better IMHO)
In a module, add the following:
Function Return_TxtFoundContact() As String
Dim ObjNamesDialog As Outlook.SelectNamesDialog
Set ObjNamesDialog = Outlook.Session.GetSelectNamesDialog
Dim ObjAddressEntry As Outlook.AddressEntry
With ObjNamesDialog ' 1. With ObjNamesDialog
.Caption = "Select contact to mention & notify": .ToLabel = "Mention:"
.NumberOfRecipientSelectors = olShowTo: .AllowMultipleSelection = False 'although with this setting it lets user to select more than one recipient
If .Display Then ' 1. If .Display
TxtEntryID = .Recipients(1).EntryID: Set ObjAddressEntry = Outlook.Application.Session.GetAddressEntryFromID(TxtEntryID)
Return_TxtFoundContact = ObjAddressEntry.GetExchangeUser.PrimarySmtpAddress
End If ' 1. If .Display
End With ' 1. With ObjNamesDialog
Set ObjAddressEntry = Nothing: Set ObjNamesDialog = Nothing
End Function
Sub Test()
Call Exec_SendNotificationMentionMail("sample#domain.com", Range("E4"))
End Sub
Sub Exec_SendNotificationMentionMail(TxtEmailToSendTo As String, RangeCommentIs As Range)
Dim AppOutlook As Outlook.Application
Set AppOutlook = New Outlook.Application
Dim ObjMailItem As Outlook.MailItem: Set ObjMailItem = AppOutlook.CreateItem(olMailItem)
With ObjMailItem
ObjMailItem.To = TxtEmailToSendTo
'since you may have many users under outlook, I rather to get the application username, however you may go to https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.currentuser
'to see how to get the username by outlook or use Environ("Username"), varies per needs/company to get the desired outcome
ObjMailItem.Subject = Application.UserName & " mentioned you in '" & ThisWorkbook.Name & "'"
'If you wish, format it as microsoft would do, just research on how to give format to the htmlbody on outlook, for simplicity I just add the basic
ObjMailItem.HTMLBody = Application.UserName & " mentioned you at: " & RangeCommentIs.Address(False, False) & Chr(10) & RangeCommentIs.CommentThreaded.Text
'for debug purposes, display it, once you have verified it works as you would like, comment the line
.Display
'Once you have verified it works as intended, uncomment this
'.Send
End With
'Once you have verified it works as intended, uncomment this
'Set ObjMailItem = Nothing: Set AppOutlook = Nothing
End Sub
In your userform, add a textbox where, upon double clicking, user agenda (per code above) would show up to select from the directory the person being mentioned
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim TxtFoundContact As String
TxtFoundContact = Return_TxtFoundContact
TextBox1 = TxtFoundContact
End Sub
Finally, on your userform implementation when they hit "OK" or when your userform appends the comment to a mail and send it using the routine.
OT: This method may be more useful than the actual one, you may select users that the workbook has not been shared with, if they get mentioned, but they do not have access yet, they can request it (I think the communication process will be faster with this). I am not quite sure if the original implementation allows it, but if needed, multiple people can be notified under the same mail too, you just need to adjust the code above to do so.

Trouble with sending emails with vba via IBM Notes

with the function below, I have the option of sending e-mails from Excel via IBM Notes. Basically, it works very well. However, I recently had to revise the code, as the message text was always inserted under the IBM Notes signature. I was able to solve this problem, but unfortunately two problems have now emerged that I did not had before.
I am grateful for every tip and every help!
UPDATE 21.12.2021 21:30: #Tode I've followed your instructions but the problems are still there. May be I've failed to put the codelines in the right order?
The problems
The "Save" function no longer works, i.e. IBM Notes also saves the e-mail in the "Sent" folder if I do not want it (parameter blnSaveEMail = false).
The second problem has to do with my work context: I have two email accounts. A personal service e-mail address jdoe#company.com (mailfile: jdoe.nsf) and a branch e-mail address mybranch#company.de (mailfile: mybranch.nsf). As far as I could determine, both mail files are in the same base directory. If I use the code below with my personal e-mail, the parameter blnQuickSend = true works without problems, if I use my branch e-mail address, IBM Notes asks me whether I want to save the changes, although I would like to send an e-mail without asking.
I hope I was able to describe my issue clearly and understandably. I thank you for your attention!
Warm greetings from Dresden
Sergeij
PS: I'am a german native :), thankfully Google helped me a lot to translate my problem in english.
The code
Public Function Send_EMail( _
varRecipient As Variant, _
varCopyTo As Variant, _
varBlindcopyTo As Variant, _
strSubject As String, _
strMessage As String, _
strAttachement As String, _
Optional blnSaveEMail As Boolean = True, _
Optional blnQuickSend As Boolean = False, _
Optional strAlternative_Mailfile As String _
) As Boolean
Dim objLotusNotes As Object
Dim objMaildatabase As Object 'Die Maildatabase
Dim strMailServer As String 'Der Mailserver
Dim strMailFile As String ' Die Maildatei
Dim objEMail As Object 'Die E-Mail in IBM Notes
Dim objAttachement As Object 'Das Anlage Richtextfile Object
Dim objSession As Object 'Die Notes Session
Dim objEmbedded As Object 'Attachement
Dim arrAttachements() As String 'Liste mehrere Anhänge
Dim lngIndex As Long
Dim strFilepath As String
Dim objNotesfield As Object 'Datenfeld in IBM Notes
Dim objCurrentEMail As Object 'Aktuelle E-Mail
'Start an IBM Notes Session
Set objSession = CreateObject("Notes.NotesSession")
'Open IBM-Notes-Database
strMailServer = objSession.GetEnvironmentString("MailServer", True)
If VBA.Len(strAlternative_Mailfile) = 0 Then
strMailFile = objSession.GetEnvironmentString("MailFile", True)
Else
strMailFile = "mail/" & strAlternative_Mailfile
End If
Set objMaildatabase = objSession.GETDATABASE(strMailServer, strMailFile)
'If your constructed path (variable strMailFile) is wrong or the database cannot be accessed
'then this line will make sure to fallback to the mailfile configured in your location document in Notes Client.
If Not objMaildatabase.IsOpen Then objMaildatabase.OPENMAIL
'Create new email
Set objEMail = objMaildatabase.CREATEDOCUMENT
'set saveoption
objEMail.ReplaceItemValue "SAVEOPTIONS", "0"
'Put content in fields
Set objNotesfield = objEMail.APPENDITEMVALUE("Subject", strSubject)
Set objNotesfield = objEMail.APPENDITEMVALUE("SendTo", varRecipient)
Set objNotesfield = objEMail.APPENDITEMVALUE("BlindCopyTo", varBlindcopyTo)
Set objNotesfield = objEMail.APPENDITEMVALUE("CopyTo", varCopyTo)
'Load workspace
Set objLotusNotes = CreateObject("Notes.NotesUIWorkspace")
'Add attachements
arrAttachements = VBA.Split(strAttachement, ";")
For lngIndex = LBound(arrAttachements) To UBound(arrAttachements)
strFilepath = arrAttachements(lngIndex)
If strFilepath <> "" And VBA.Dir(strFilepath) <> "" Then
Set objAttachement = objEMail.CREATERICHTEXTITEM("Attachment" & lngIndex)
Set objEmbedded = _
objAttachement.EMBEDOBJECT(1454, "", strFilepath, "Attachment" & lngIndex)
End If
Next
'Open eMail in frontend and assign to NotesUIDocument variable
Set objCurrentEMail = objLotusNotes.EDITDOCUMENT(True, objEMail)
'Put content into email
objCurrentEMail.GotoField "Body"
objCurrentEMail.InsertText strMessage
'Check, whether the email should be sent immediately or not
If blnQuickSend = True Then
'Send email
objCurrentEMail.Send
'Save email, if requested
If blnSaveEMail Then objCurrentEMail.Save
'Close email
objCurrentEMail.Close
End If
'Return TRUE
Send_EMail = True
End Function
Ok... where should I start... there are some logical errors in your code based on not understanding the methods you use and the difference between frontend- and backend- classes...
Let's begin at the top:
'Check whether the maildatabase is open or not 'Throws an error,
'if the database is not open
If Not objMaildatabase.IsOpen Then objMaildatabase.OPENMAIL
Your comment is wrong. No error is thrown at all. If your constructed path (variable strMailFile) is wrong or the database cannot be accessed then this line will make sure to fallback to the mailfile configured in your location document in Notes Client.
'Create new email-document
objLotusNotes.EDITDOCUMENT True, objEMail
Again: Comment is wrong. What this command does is: It opens the email that you created in backend (represented by variable objEMail) in the frontend.
'Select the current email
Set objCurrentEMail = objLotusNotes.CurrentDocument
and assigns it to a NotesUIDocument- frontend- variable (select the current email is wrong).
As "EDITDOCUMENT" already returns as NotesUIDocument, you could shorten this like this:
'Open eMail in frontend and assign to NotesUIDocument variable
Set objCurrentEMail = objLotusNotes.EDITDOCUMENT(True, objEMail)
After having created a frontenddocument you still continue to manipulate the (now linked) backend document. You should move the creation of the frontend all the way down to the end of your code as having a document open in frontend does not work well with manipulating the same document in backend, especially when handling NotesRichtextItems and attachments. So move the above lines just below the for- loop.
'Set if email should be saved or not
objEMail.SAVEMESSAGEONSEND = blnSaveEMail
Yes... but no: You set the property SAVEMESSAGEONSEND to the backend document objEMail. Unfortunately the frontend- document objCurrentEMail does not care at all for this. To have your code obey this option, you would have to use the send- method of objEMail, not the send- method of objCurrentEMail.
If you want the frontend to not save a document that it sends, you need to do it differently by setting a field called "SAVEOPTIONS" to "0":
objEMail.ReplaceItemValue( "SAVEOPTIONS", "0" )
'Send email
objCurrentEMail.Send False, varRecipient
regarding your comment: almost... unfortunately you try the NotesDocument backend method "send" (that has 2 parameters) against the NotesUIDocument- Object "objCurrentEMail.
NotesUIDocument has a send method as well, but it does not have any parameters..normally an error should be thrown here....
EITHER you try to send the backend:
objEMail.Send False, varRecipient
OR you send it in the frontend:
objCurrentEMail.Send
Your "objCurrentEMail.Close" will always ask you if you want to save the document unless you have set SAVEOPTIONS = "0". If you really want to save the document after sending, use
objCurrentEMail.Save
before the close.
Hope that helps you sort out some of the issues.

VBA Excel - How to reply all with email addresses, not just names

I'm making a VBA userform that replies to the active Outlook email with a template (different templates based on listbox choices). The problem right now is that when I "reply all" it is grabbing just the first and last name of the sender and recipients.
The senders are primarily outside the company, so I need it to grab and populate the "To" field with the actual email addresses. If it were only in-company the users would be in the company directory and it wouldn't be an issue. The closest I've come to finding this is the answer to How do you extract email addresses from the 'To' field in outlook?. I feel like the information I need is available there (only explicitly deals with grabbing info for recipients but I figure the same principle will apply to the sender), but I can't make sense of how to insert it into my code for the desired result.
Here's what I am starting from:
Private Sub CommandButton1_Click()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Set origEmail = ActiveExplorer.Selection(1)
Set replyEmail = CreateItemFromTemplate("C:\Download Tool\Need Stat Code X.oft")
replyEmail.To = origEmail.ReplyAll.To
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.SentOnBehalfOfName = "emailaddress#mycompany.com"
replyEmail.Display
Set origEmail = Nothing
Set replyEmail = Nothing
End Sub
The emails are populating and I'm getting nearly all the info I want, but I haven't found a clear explanation of how to grab & insert the email addresses.
Thanks for your time and advice!
If you put a stop after "Set origEmail = ..." and set a watch on origEmail, you will see the properties of the email. Included is the Recipients collection. There are two (that I can see) types, SMTP and EX. For me, EX means internal. in each item in the recipients items is a property called address and another called addressentry. The addressentry part contains the address type.
deep breath
OK, so you need to be able to convert the EX addresses into internal addresses by parsing the part at the end, and you can just put the SMTP ones in as is, I think. Build a string of the addresses in the recipients address list and put it in the To and/or CC fields and you should be good. The To or CC part is the recipients (n).type property...
I think.
Gosh, I hope someone posts an easier way to do it :)
Thanks to both #hrothgar and #Tony for the responses. I learned about some new tools and techniques from each. Ultimately, based on the info found in your responses, I ended up searching for "vba get recipients string" and finding Get item.recipient with Outlook VBA .
The code now works and looks like this:
Private Sub CommandButton1_Click()
Dim origEmail As MailItem
Dim replyEmail As MailItem
'new stuff
Dim recip As Recipient
Dim allRecips As String
'end new stuff
Set origEmail = ActiveExplorer.Selection(1)
Set replyEmail = CreateItemFromTemplate("C:\Template Placel\My Template.oft")
'more new stuff
For Each recip In origEmail.Recipients
If (Len(allRecips) > 0) Then allRecips = allRecips & "; "
allRecips = allRecips & recip.Address
Next
'end more new stuff
replyEmail.To = origEmail.SenderEmailAddress & "; " & allRecips 'updated to find sender email and
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.SentOnBehalfOfName = "inbox#company.com"
replyEmail.Display
Set origEmail = Nothing
Set replyEmail = Nothing
End Sub
The internal contacts look a bit ugly in the "To" line, but I've tested and it gets the job done.
Thanks for the help!

Resources