I have the following vba code, which runs from Excel. It sends an email to a list of recipients in a range.
Sub Send_Email()
Dim answer As Integer
answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
If answer = vbNo Then
Exit Sub
Else
Dim rnBody As Range
Dim Data As DataObject
Set rnBody = Worksheets(1).Range("N3")
rnBody.Copy
Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
Dim i As Long
Dim j As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, ws As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row
j = 18
'Start a session of Lotus Notes
Set Session = CreateObject("Lotus.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Call Session.Initialize
'Open the Mail Database of your Lotus Notes
user = Session.UserName
usersig = Session.CommonUserName
server = Session.GetEnvironmentString("MailServer", True)
mailfile = Session.GetEnvironmentString("MailFile", True)
Set Maildb = Session.GetDatabase(server, mailfile)
If Not Maildb.IsOpen = True Then Call Maildb.Open
With ThisWorkbook.Worksheets(1)
For i = 18 To LastRow
'Create the Mail Document
Session.ConvertMime = False ' Do not convert MIME to rich text
Set MailDoc = Maildb.CREATEDOCUMENT
Call MailDoc.ReplaceItemValue("Form", "Memo")
'Set From
Call MailDoc.ReplaceItemValue("Principal", "Food.Specials#Lidl.co.uk")
Call MailDoc.ReplaceItemValue("ReplyTo", "Food.Specials#Lidl.co.uk")
Call MailDoc.ReplaceItemValue("DisplaySent", "Food Specials")
Call MailDoc.ReplaceItemValue("iNetFrom", "Food.Specials#Lidl.co.uk")
Call MailDoc.ReplaceItemValue("iNetPrincipal", "Food.Specials#Lidl.co.uk")
'Set the Recipient of the mail
Call MailDoc.ReplaceItemValue("SendTo", Range("Q" & i).value)
'Call MailDoc.ReplaceItemValue("CopyTo", "food.specials#lidl.co.uk")
'Set subject of the mail
Call MailDoc.ReplaceItemValue("Subject", "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
'Create and set the Body content of the mail
Set Body = MailDoc.CREATERICHTEXTITEM("Body")
If Range("I10").value <> "" Then
Call Body.APPENDTEXT("Good " & Range("A1").value & "," & vbNewLine & vbNewLine _
& "Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & "." & vbNewLine & vbNewLine _
& "Please can you confirm within 24 hours." & vbNewLine & vbNewLine _
& Range("I10").value & vbNewLine)
Else
Call Body.APPENDTEXT("Good " & Range("A1").value & "," & vbNewLine & vbNewLine _
& "Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & "." & vbNewLine & vbNewLine _
& "Please can you confirm within 24 hours." & vbNewLine)
End If
'Embed Excel Sheet Range
Set Data = New DataObject
Data.GetFromClipboard
Call Body.ADDNEWLINE(2)
Call Body.EmbedObject(1454, "", Range("F" & i).value, "Attachment")
'create an attachment (optional)
Call Body.ADDNEWLINE(3)
Call Body.APPENDTEXT(Data.GetText)
'create an attachment (optional)
Call Body.ADDNEWLINE(4)
Call Body.APPENDTEXT(Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0))
'Example to save the message (optional) in Sent items
MailDoc.SaveMessageOnSend = True
'Send the document
'Gets the mail to appear in the Sent items folder
Call MailDoc.ReplaceItemValue("PostedDate", Now())
Call MailDoc.Send(False)
Set MailDoc = Nothing
j = j + 1
Next i
End With
'Clean Up the Object variables - Recover memory
Set Maildb = Nothing
Set Body = Nothing
Set Session = Nothing
Application.CutCopyMode = False
MsgBox "Success!" & vbNewLine & "Announcements have been sent."
End If
End Sub
The code semi works. Emails are sent fine.
However, i want to be able to add the default signature to the bottom of my email. I am trying to do this using this line but its not adding any signature.
'create an attachment (optional)
Call Body.ADDNEWLINE(4)
Call Body.APPENDTEXT(Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0))
My signature contains an image, and i'm wondering if this won't pull through the signature because my email isn't html?
In which case then, how could i change this email to html?
Please can someone show me what i am doing wrong?
Your suspicion is correct. This won't work since you're creating a Notes rich text email message - but the solution is not necessarily switching to creating a MIME/HTML message. The NotesRichTextItem class's AppendText method can only handle text, but if the Notes signature is in rich text format, it's actually the Signature_Rich item that you should be working with, not the Signature item, and you should be using the AppendRTItem method instead of the AppendText method.
The truth is, though, that with two different mail formats and several different options for the way the signature is managed in the user's profile, this is a non-trivial problem to handle for all of the different cases that you might have to handle. You really have to look at the SignatureOption item value, which is "3" if it is rich text, "2" if it's an HTML or image file, and "1" if it is plain text. The solution in your code is going to be different depending on which one is being used, and coping with option 2 while creating a rich text message isn't going to be easy.
You might want to check out the answer to this previous question for an example of building a MIME message if you want to get away from using Notes rich text. And while I haven't vetted the code in this blog post, it shows appending a signature - it looks like it is assuming that the signature is in a file rather than checking the SignatureOptions item.
Related
I've been trying to write a macro in VBA to send an e-mail to the users of the excel after the document has been edited and saved. To make it clear let's say Person 1 edited the document by changing cell C4 and F6 etc. After Person 1 clicked save I want this macro to trigger and send an e-mail to every user that use this document so there won't be any need for anyone to write or say everyone what they changed. I am a mechanical engineer and have no background in coding. I managed the part where macro triggers after document has been saved which is the easy part but I can't add which cell(s) edited in the mail body. Here is what I did. I am looking for your help.
Note: The code is in display rn bcs I dont want to get useless mails just to try if it works or not.
Public Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call Send_Email
End Sub
Public Sub Send_Email()
Dim username As Namespace
Dim olMail As MailItem
Set username = GetNamespace("MAPI")
Set olMail = CreateItem(olMailItem)
With olMail
.Subject = "Excel File " & ThisWorkbook.Name & " Modified by " & Application.username
.To = "***#***.com; "
.Body = "Excel file " & ThisWorkbook.FullName & " at" & " was modified by " & Application.username & " on " & Format(Now(), "mm-dd-yyyy") & " at " & Format(Now(), "hh:mm:ss AM/PM") & "."
.SendUsingAccount = username.Accounts.Item(1)
.Display
End With
Set olMail = Nothing
Set username = Nothing
End Sub
Sorry but I was trying to find the answer for hours but could not figure it out.
I tried playing with vbNewLine and vbCrLf but could not make it to work in the function and in the function call.
How do I add a new line with the code below?
Tried this but it did not work:
checker = MessageTimeOut("Underlying raw data in the workbook has been updated." & vbNewLine & "This will close automatically.", "UPDATE RAW DATA - COMPLETED", 5)
Also tried:
checker = MessageTimeOut("Underlying raw data in the workbook has been updated." & vbCrLf & "This will close automatically.", "UPDATE RAW DATA - COMPLETED", 5)
I want the "This will close automatically." shown in a new line.
Function MessageTimeOut(str_message As String, str_title As String, int_seconds As Integer) As Boolean
Dim Shell
Set Shell = CreateObject("WScript.Shell")
Shell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(""" & str_message & """," & int_seconds & ",""" & str_title & """))"
MessageTimeOut = True
End Function
Sub Some_Sub()
' some lengthy code....
Dim checker As Boolean
checker = MessageTimeOut("Underlying raw data in the workbook has been updated. This will close automatically.", "UPDATE RAW DATA - COMPLETED", 5)
EDIT: My previous answer wasn't using mshta which I think you needed in order to make your message asynchronous and allow your code to continue...
This does the trick:
Sub Test2()
mshta "Me`s`s`age", "test", 5 '<<< all backticks become newlines
Debug.Print "This runs right away"
End Sub
Function mshta(ByVal MessageText As String, Optional ByVal Title As String, _
Optional ByVal PauseTimeSeconds As Integer)
Dim ConfigString As String, WScriptShell
Set WScriptShell = CreateObject("WScript.Shell")
ConfigString = "mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(Replace(""" & MessageText & """,""`"",vbLf)," & PauseTimeSeconds & ",""" & Title & """))"
WScriptShell.Run ConfigString
End Function
I want to display Outlook Calendar appointments from a given date in a MessageBox. Unfortunately the code I am using does not show any appointments for today. If i change my code to
sfilter = "[Start] >= '" & startDate & "' "
then i get todays appointments with all future appointments for other dates. I want to only show appointments for the specified date.
The date selection is from a UserForm called cmDates.srtDate.Value
sFilter is the variable I am using the hold the date filter throughout the code
Code
Public Function getOutlookAppointments() As String
Dim oOutlook As Object
Dim oNS As Object
Dim oAppointments As Object
Dim oFilterAppointments As Object
Dim oAppointmentItem As Object
Dim bOutlookOpened As Boolean
' Dim rslt As String
Dim sfilter As String
Dim startDate As Date
Dim displayText As String
Dim start As Date
Const olFolderCalendar = 9
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
bOutlookOpened = False 'Outlook was not already running, we had to start it
Else
bOutlookOpened = True 'Outlook was already running
End If
On Error GoTo Error_Handler
DoEvents
Set oNS = oOutlook.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
startDate = cmDates.srtDate.value
'Apply a filter so we don't waste our time going through old stuff if we don't need to.
sfilter = "[Start] = '" & startDate & "' "
Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
For Each oAppointmentItem In oFilterAppointments
getOutlookAppointments = getOutlookAppointments & oFilterAppointments.Count & " appointment(s) found" & vbCrLf & vbCrLf & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & vbCrLf & oAppointmentItem.End & vbCrLf & vbCrLf
'displayText = displayText & oAppointmentItem.Subject
Next
MsgBox prompt:=getOutlookAppointments, _
Title:="Appointments for"
If bOutlookOpened = False Then 'Since we started Outlook, we should close it now that we're done
oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
End If
Error_Handler_Exit:
On Error Resume Next
Set oAppointmentItem = Nothing
Set oFilterAppointments = Nothing
Set oAppointments = Nothing
Set oNS = Nothing
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFutureOutlookEvents" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
outlookDates = False
End Function
Your restriction should have two parts - Start > today's midnight, and Start < tomorrow's midnight. You only have the first part.
Also keep in mind that if you want instances of the recurring activities (and not just the master appointments), you need to use the Items.IncludeRecurrences property - see https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
There are several aspects:
To retrieve all Outlook appointment items from the folder that meets the predefined condition, you need to sort the items in ascending order and set the IncludeRecurrences to true. You will not catch recurrent appointments if you don’t do this before using the Restrict method!
Microsoft doesn’t recommend using the Count property in case you set the IncludeRecurrences property. The Count property may return unexpected results and cause an infinite loop.
Although dates and times are typically stored with a Date format, the Find and Restrict methods require that the date and time be converted to a string representation. To make sure that the date is formatted as Microsoft Outlook expects, use the Format function available in VBA. So, you must specify the date in the format which Outlook understand.
Format(youDate, "ddddd h:nn AMPM")
For example, here is a sample VB.NET code:
Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
" AND [End]>=""" + DateTime.Now.ToString("g") + """"
Dim strBuilder As StringBuilder = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItems As Outlook.Items = Nothing
Dim appItem As Outlook._AppointmentItem = Nothing
Dim counter As Integer = 0
Dim item As Object = Nothing
Try
strBuilder = New StringBuilder()
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
resultItems = folderItems.Restrict(restrictCriteria)
item = resultItems.GetFirst()
Do
If Not IsNothing(item) Then
If (TypeOf (item) Is Outlook._AppointmentItem) Then
counter = counter + 1
appItem = item
strBuilder.AppendLine("#" + counter.ToString() + _
" Start: " + appItem.Start.ToString() + _
" Subject: " + appItem.Subject + _
" Location: " + appItem.Location)
End If
Marshal.ReleaseComObject(item)
item = resultItems.GetNext()
End If
Loop Until IsNothing(item)
If (strBuilder.Length > 0) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " _
+ folder.Name + " folder.")
End If
catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
End Try
End Sub
You may find the following articles helpful:
How To: Use Restrict method in Outlook to get calendar items
How To: Retrieve Outlook calendar items using Find and FindNext methods
I wanted to extract list of defects using a filter criteria. I tried the VBA code from OTA here, but compile fails on the following declarations with User defined type not defined:
Dim BugFact As BugFactory
Dim BugFilter As TDFilter
Dim bugList As List
Dim theBug As Bug
Note: I do not have administrative privileges on ALM.
The full VBA code:
Sub BugFilter()
Dim BugFact As BugFactory
Dim BugFilter As TDFilter
Dim bugList As List
Dim theBug As Bug
Dim i%, msg$
' Get the bug factory filter.
'tdc is the global TDConnection object.
Set BugFact = tdc.BugFactory
Set BugFilter = BugFact.Filter
' Set the filter values.
BugFilter.Filter("BG_STATUS") = "Closed"
BugFilter.order("BG_PRIORITY") = 1
MsgBox BugFilter.Text
'Create a list of defects from the filter
' and show a few of them.
Set bugList = BugFilter.NewList
msg = "Number of defects = " & bugList.Count & Chr(13)
For Each theBug In bugList
msg = msg & theBug.ID & ", " & theBug.Summary & ", " _
& theBug.Status & ", " & theBug.Priority & Chr(13)
i = i + 1
If i > 10 Then Exit For
Next
MsgBox msg
End Sub
You need to add a reference to the OTA COM Type library (see here); otherwise your program will not know about the OTA types such as BugFactory and TDFilter.
I have an Excel spreadsheet of contacts. I want to set a drop-down list that sends an email to the specific person I choose and returns the contact info in the body of the email.
I don't know how to get the email to auto-populate and right now, the email that pops up has "true" in the body for the contact info rather than returning the text value in the cell.
Sub DropDown7_Change()
Dim answer As String
answer = MsgBox("Are you sure you want to assign this lead?", _
vbYesNo, "Send Email")
' Above code informs the user that an automated email will be sent
'Code uses the users answer to either carryout the generated email process or to not save the changes.
If answer = vbNo Then Cancel = True
If Cancel = True Then Exit Sub
If answer = vbYes Then
'Connects to outlook and retrieves information needed to create and send the email.
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set newmsg = OutlookApp.CreateItem(olMailItem)
'Contains the email address of the person receiving the email.
newmsg.Subject = "Lead Assigned to You" 'Sets the automated subject line to the email
newmsg.Body = "Hello," & vbNewLine & _
"You have been assigned a lead. Please follow up with the contact" & vbNewLine & _
ActiveCell.Offset(0, 3).Range("K5").Select
ActiveCell.Offset(0, 6).Range("K5").Select
ActiveCell.Offset(0, 7).Range("K5").Select
'Above code has the body of the automated email
newmsg.Display
End If
End Sub ' End of function
If you are trying to get the values that are Offset to Range("K5") , then you need to use the Offset with .Value , like this Range("K5").Offset(0, 3).Value , this will get the value 3 columns to the right of Cell "K5".
The code below, will add the values from 3 cells with Columns offset to cell "K5" to you email body:
Sub DropDown7_Change()
Dim answer As String
answer = MsgBox("Are you sure you want to assign this lead?", _
vbYesNo, "Send Email")
' Above code informs the user that an automated email will be sent
'Code uses the users answer to either carryout the generated email process or to not save the changes.
If answer = vbNo Then
Exit Sub
Else
If answer = vbYes Then
'Connects to outlook and retrieves information needed to create and send the email.
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set newmsg = OutlookApp.CreateItem(olMailItem)
'Contains the email address of the person receiving the email.
newmsg.Subject = "Lead Assigned to You" 'Sets the automated subject line to the email
newmsg.body = "Hello," & vbNewLine & _
"You have been assigned a lead. Please follow up with the contact" & vbNewLine & _
Range("K5").Offset(0, 3).Value & vbNewLine & _
Range("K5").Offset(0, 6).Value & vbNewLine & _
Range("K5").Offset(0, 7).Value & vbNewLine
'Above code has the body of the automated email
newmsg.Display
End If
End If
End Sub