Inserting email signature using vba in Excel 2013 - vba

This sub in an Excel VBA application that has worked well for years, inserting an Outlook signature into an email before displaying the email for me to send (.Display). This has worked in Excel 2007 in Windows XP and 2013 in Windows 7.
Now I have Windows 8.1 and Office 2013 this comes out with Error 91 in my error routine. Could it be a problem with one of the References? - or some change needed in the code?
Sub InsertSig2007(strSigName As String)
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' requires a project reference to the
' Microsoft Office library
Dim objCBP As Office.CommandBarPopup
Dim objCBP2 As Office.CommandBarPopup
Dim objCBB As Office.CommandBarButton
Dim colCBControls As Office.CommandBarControls
Set objInsp = ActiveInspector
If Not objInsp Is Nothing Then
Set objItem = objInsp.CurrentItem
If objItem.Class = olMail Then
' get Insert menu
Set objCBP = objInsp.CommandBars.ActiveMenuBar.FindControl(, 30005)
' get Signature submenu
Set objCBP2 = objCBP.CommandBar.FindControl(, 5608)
If Not objCBP2 Is Nothing Then
Set colCBControls = objCBP2.Controls
For Each objCBB In colCBControls
Debug.Print objCBB.Caption
If objCBB.Caption = strSigName Then
objCBB.Execute ' **** see remarks
Exit For
End If
Next
End If
End If
End If
Set objInsp = Nothing
Set objItem = Nothing
Set colCBControls = Nothing
Set objCBB = Nothing
Set objCBP = Nothing
Set objCBP2 = Nothing
End Sub

"this comes out with Error 91 in my error routine" When debugging do not use an error routine. That way you see the line with the problem and can say what it is in your question.
It is probably
Set objCBP = objInsp.CommandBars.ActiveMenuBar.FindControl(, 30005)
See CommandBars.FindControl Method (Office)
"The use of CommandBars in some Microsoft Office applications has been superseded by the new ribbon component of the Microsoft Office Fluent user interface."
Note: CommandBars.ExecuteMso Method (Office) works in 2013 but I believe the signature button is not available.
You will surely find a replacement for your code here Insert Outlook Signature in mail.
Likely this one:
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
'Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
'Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)
Set OutMail = CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"Ron's Excel Page" & _
"<br><br><B>Thank you</B>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Mysig.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
'.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br>" & Signature
'.Send
'or use
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
'Set OutApp = Nothing
End Sub
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

Related

Setting Range based on Selection

I want to take a reference number in an email to highlight and replace with a direct link to web page.
The current code will place the new hyperlink at the start of the email instead of the selected areas (currently wddoc.Range(0 , 0)).
If I use Selection it says the variable is undefined by user.
Sub AddHyperlink()
Dim olEmail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim strLink As String
Dim strLinkText As String
Dim OutApp As Object
Dim OutMail As Object
Dim strText As String
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
strLink = "http://website.com/#" & strText & "" ' the link address
strLinkText = "" & strText & "" ' the link display text
On Error Resume Next
Set olEmail = ActiveInspector.CurrentItem
With olEmail
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0) '!!!Cannot find something that replaces range with current selection!!!!
oRng.Collapse 0
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=strLinkText)
Set oRng = oLink.Range
oRng.Collapse 0
.Display
End With
lbl_Exit:
Exit Sub
End Sub
When I have a new email open in MS Outlook, I'll have a keyboard shortcut setup to run the code in VBA within Outlook.
Outlook vba while working with ActiveInspector, try the following.
Option Explicit
Public Sub Example()
Dim wdDoc As Word.Document
Dim rngSel As Word.selection
If Application.ActiveInspector.EditorType = olEditorWord Then
Set wdDoc = Application.ActiveInspector.WordEditor ' use WordEditor
Set rngSel = wdDoc.Windows(1).selection ' Current selection
wdDoc.Hyperlinks.Add rngSel.Range, _
Address:="U:\plot.log", TextToDisplay:="Here is the link"
End If
Set wdDoc = Nothing
End Sub

Send SECURE email with Outlook via VBA

I have a simple code to open Microsoft Outlook and send an email with an attachment. I would like to send the email securely. Meaning, I would like to know if there is any code that would be tantamount to pressing the "Send Securely" button in outlook. Here is my code so far.....
Sub EmailInvoice()
Dim OutlookApp As Object, OutlookMessage As Object
Dim FileName As String, EmailAddress As String
EmailAddress = Range("ProviderEmail").Value
FileName = "C:\Users\rblahblahblah.txt"
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if
Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp =
CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
Exit Sub
End If
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
With OutlookMessage
.To = EmailAddress
.CC = ""
.BCC = ""
.Subject = "Invoice for Upload - " & Month
.Body = "Please upload the attached file to the Vendor Portal."
.Attachments.Add FileName
.Display
.Send
End With
End Sub
The code below will send it with a sensitivity enumeration but not securely (Certified Mail). I also add my signature (Default) to the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
For Each cell In ThisWorkbook.Sheets("Email List").Range("B1:B100")
If cell.Value Like "?*#?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.to = strto
.CC = ""
.BCC = ""
.Subject = ("*Confidential*: Policyholder Name Here - Policy # Here - Premium Bill")
.HTMLBody = "Attached is the most recent premium bill in Excel." & "<br><br>" & Signature
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Importance = 2 '(0=Low, 1=Normal, 2=High)
.Sensitivity = 3 '(0=Normal, 1=Personal, 2=Private, 3=Confidential)
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
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

Add signature with images to the Mail

I have a macro for Outlook where I can create a complete mail with an attachment but can not add a signature saved in my C drive (C:\Users\JustinG\AppData\Roaming\Microsoft\Signatures).
Signature types are .rtf and .htm with images.
The following is the code:
Sub Mail_Workbook_1()
Dim OutApp As Object
Dim Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With Outmail
.SentOnBehalfOfName = "justin.gatlin#rediffmail.com"
.To = "abc#xyz.com"
.CC = ""
.BCC = ""
.Subject = "Presentation"
.Body = "Hi Team,"
.Attachments.add ("C:\Users\DurshetwarA\Desktop\Excel Examination_Master_V1.xlsx")
.display
''SendKeys ("%s")
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
End Sub
In the .htm file in the signatures directory you can edit the htm file. The pictures are stored as relative path and when you use the code it looses that path so if you use discrete path it will be able to find the pictures. so go into the file and look for any relative paths and make them discrete.
"/Microsoft/Signatures/picturefile.jpg"
change that to include the whole path
"/root/user/blah blah../Microsoft/Signatures/picturefile.jpg"
This solved the missing image problem for me.
Solution described here by Ron de Bruin.
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"Ron's Excel Page" & _
"<br><br><B>Thank you</B>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Mysig.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br>" & Signature
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
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
Instead of .body use .htmlbody and design your message body in HTML. This is the only way of inserting image in your message. There is no specific option to insert signature
Similar to the solution posted by Adavid02, here you may find a more detailed explanation.

How to get From field from Outlook using vba macro

I am writing macro that will set a signature after choosing the From field or for example clicking reply. My problem is that I don't know how to get the From field value. I know how to set this field.
Function GetBoiler(ByVal sFile As String) As String
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
Function GetSignature(Mailbox As String) As String
Dim Signature As String
Dim SigStringPL As String
Dim SigStringUK As String
SigStringPL = Environ("appdata") & _
"\Microsoft\Signatures\Poland.htm"
SigStringUK = Environ("appdata") & _
"\Microsoft\Signatures\United Kingdom.htm"
If Mailbox = "poland#poland.pl" Then
If Dir(SigStringPL) <> "" Then
GetSignature = GetBoiler(SigStringPL)
Else
GetSignature = ""
End If
Else
If Dir(SigStringUK) <> "" Then
GetSignature = GetBoiler(SigStringUK)
Else
GetSignature = ""
End If
End If
End Function
Sub Mail_Outlook_With_Signature_Plain()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "content"
Signature = GetSignature("erni#erni.pl")
MsgBox (OutMail.SentOnBehalfOfName)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.subject = "This is the Subject line"
.HTMLBody = strbody & "<br><br>" & Signature
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Regards,
erni
SenderName is the field name for 'From' field.
From is SentOnBehalfOfName. In normal use, it is empty until the item has been sent.
Do not choose the From manually.
Sub replySentOnBehalf()
Dim objMsg As mailitem
Set objMsg = ActiveInspector.currentItem.reply
objMsg.SentOnBehalfOfName = "someone#somewhere.com"
' Now that objMsg.SentOnBehalfOfName is available run your code
objMsg.Display
Set objMsg = Nothing
End Sub

VBA in notepad to run code in Excel error

This is the code I have saved in Notepad. Do I need to change Excel.Applications?
Option Explicit
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("H:\shane.xlsm", 0, True)
xlApp.Run "Email"
xlBook.close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = nothing
This is the code I have to send the email and when I test it works fine and will send me an email.
Option Explicit
Const strTo As String = "dvandervieren#enerplus.com"
Const strCC As String = "" '<~~ change "def#abc.com" to "" if you do not want to CC
Const strBCC As String = "" '<~~ change "ghi#abc.com" to "" if you do not want to BCC
Sub Email()
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strSubject As String
strSubject = "Hello World"
strbody = "This is the message for the body"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = "This is the Subject line"
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Open Your excel document. Open the VB Editor. Find the excel document in the left hand window pane. Right click and select Insert>>Module. Move your code into the newly created module. You should then be able to call it using just the method name Email. You do not need to delcare an excel application as you are already inside of excel. – Sorceri