I have a function which creates an appointment in Outlook. My problem is, that it does not add any recipients. I tried it with a CheckedListBox and with strings only (hardcoded), but it does not work.
The appointment itselfs gets created, but with no recipients..
That´s my code:
Dim app As Microsoft.Office.Interop.Outlook.Application
Dim appt As Microsoft.Office.Interop.Outlook.AppointmentItem
app = New Microsoft.Office.Interop.Outlook.Application
appt = app.CreateItem(Microsoft.Office.Interop.Outlook.OlItemType.olAppointmentItem)
appt.Subject = tbBetreff.Text
appt.Body = tbInhalt.Text
appt.Location = tbOrt.Text
For Each itemChecked In cbContacts.CheckedItems
Dim sentTo As Outlook.Recipients = appt.Recipients
Dim sentInvite As Outlook.Recipient
sentInvite = sentTo.Add(itemChecked.ToString())
sentInvite.Type = Outlook.OlMeetingRecipientType.olRequired
sentTo.ResolveAll()
Next
appt.Start = Convert.ToDateTime("24.07.2020 13:00:00")
appt.End = Convert.ToDateTime("24.07.2020 14:00:00")
appt.ReminderSet = True
appt.ReminderMinutesBeforeStart = 30
appt.Save()
Do you see the problem?
Thank you..
First of all, you need to set the AppointmentItem.MeetingStatus property which sets an OlMeetingStatus constant specifying the meeting status of the appointment. Then you can add attendees.
The following sample code programmatically creates an appointment, sets various properties, and sends the appointment to request a meeting. CreateAppt uses the CreateItem` method to create an AppointmentItem object. It sets the MeetingStatus property of the AppointmentItem to olMeeting to indicate the appointment as a meeting request, and sets a required attendee, an optional attendee, and a meeting location as a resource. The example then displays and sends the appointment item.
Sub CreateAppt()
Dim myItem As Object
Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
Set myItem = Application.CreateItem(olAppointmentItem)
myItem.MeetingStatus = olMeeting
myItem.Subject = "Strategy Meeting"
myItem.Location = "Conf Rm"
myItem.Start = #9/24/2020 1:30:00 PM#
myItem.Duration = 90
Set myRequiredAttendee = myItem.Recipients.Add("Eugene Astafiev")
myRequiredAttendee.Type = olRequired
Set myOptionalAttendee = myItem.Recipients.Add("Kevin Kennedy")
myOptionalAttendee.Type = olOptional
Set myResourceAttendee = myItem.Recipients.Add("Conf Rm All Stars")
myResourceAttendee.Type = olResource
myItem.Display
End Sub
Related
I want to create Visual Basic scrip to create calendar event/invitation.
Script is working perfectly, when only one account is registered in outlook, and event is created OK for this single calendar (account).
PROBLEM:
I have two accounts registered in my outlook. One of the accounts is company-managed (let's call it FIRST). I have also manually created account (let's call it SECOND).
The problem is when I want to create event "on behalf" of SECOND calendar registered manually. I've already set SECOND account as primary account in outlook with:
Outlook->File->Account Settings->Account Setting...->Email Tab->Set as default.
When I'm using (almost) identical code as below to create Outlook email object, script is working perfectly fine, and field "Sender" in the message is populated with correct SECOND account name.
Picture: Email outlook object created, with SENDER populated with correct SECOND account
I've tried to set property: objAppointmentItem.SendUsingAccount = myAccount , with the SECOND account, but then Sender field is left empty, and you can't select account from combo. When I'm sending it it ANYWAY, then it is send to correct recipients, but is NOT send to my SECOND calendar (desired), and invitation/event is visible in my FIRST calendar, which I DON'T want to use anymore.
Picture: Outlook event object with FROM field empty, no selection possible
When I'm NOT setting property: objAppointmentItem.SendUsingAccount = myAccount , event object is created, but is assigned with FIRST account, despite SECOND is set as default.
Picture: Event created with wrong sender, and NO SELECTION possible for SECOND account
When I create invitation with double-click on calendar itself (SECOND account calendar), then invitation is created with correct SECOND account populated in SENDER field, (still no option to select other account - but no need, as is correct :) )
Sub OutOfOfficeEvent()
Dim oAccount As Outlook.Account
Dim myAccount As Outlook.Account
'try to find PERSONAL account. If failed, then send with last avail on the list Application.Session.Accounts
For Each oAccount In Application.Session.Accounts
Set myAccount = oAccount
If InStr(UCase(oAccount.DisplayName), "PERSONAL.COM") Then
Exit For
End If
Next
Dim objOutlookApplication As Outlook.Application
Dim objAppointmentItem As Outlook.AppointmentItem
Dim objRecipient As Recipient
Dim objRecipients As Recipients
Set objOutlookApplication = CreateObject("Outlook.Application")
Set objAppointmentItem = objOutlookApplication.CreateItem(olAppointmentItem)
'###############################################
'####### NOT working for event/invitation
'####### Working OK for email object creation
'###############################################
objAppointmentItem.SendUsingAccount = myAccount
'###############################################
objAppointmentItem.Display
Set objRecipients = objAppointmentItem.Recipients
Set objRecipient = objAppointmentItem.Recipients.Add("somebody1#PERSONAL.COM")
Set objRecipient = objAppointmentItem.Recipients.Add("somebody2#PERSONAL.COM")
objRecipient.Type = olRequired
For Each objRecipient In objAppointmentItem.Recipients
objRecipient.Resolve
Next
Dim DateStart As Date
Dim DateEnd As Date
DateStart = DateTime.DateAdd("d", 0, DateTime.DateAdd("h", 1, DateTime.DateAdd("s", -Second(Now()), DateTime.DateAdd("n", -Minute(Now()), Now()))))
DateEnd = DateTime.DateAdd("h", 1, DateStart)
With objAppointmentItem
.MeetingStatus = olMeeting
.Subject = "[OOO] " & strUser
.Start = DateStart
.End = DateEnd
.AllDayEvent = False
.ReminderSet = False
.BusyStatus = olFree
.ResponseRequested = False
.Location = ""
.Body = "Some body content"
End With
objAppointmentItem.Display
Set objOutlookApplication = Nothing
End Sub
There are several ways of creating new items in Outlook. See How To: Create a new Outlook Appointment item for more information.
If you have two accounts configured in Outlook you need to get the right calendar folder and then add a new calendar entry there. To get this done you can use the GetDefaultFolder method of the Store class which returns a Folder object that represents the default folder in the store and that is of the type specified by the FolderType argument. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile. So, you may get the right store and add the new calendar entry.
The NameSpace.Stores property returns a Stores collection object that represents all the Store objects in the current profile.
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oCalendar As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oCalendar = oStore.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
Debug.Print (oCalendar.FolderPath)
Next
End Sub
I had the same problem and with above suggestion and some more Google, I found the total solution:
Dim myAI As Outlook.AppointmentItem
myAI = Nothing
Dim oStore As Outlook.Store
For Each oStore In colStores
Dim oCalendar As Outlook.Folder
Set oCalendar = oStore.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
If LCase(oCalendar.Description) = "<accountname>" Then
Set myAI = oCalendar.Items.Add(Outlook.OlItemType.olAppointmentItem)
Exit For
End If
Next
We use the following code to create a number of items in a shared calendar. Everything works out, only the invites are not send to the optional attendees. Unfortunately the MS Docs are a bit unclear in this area:
Sub DoOne(Calendar, Subject, Start, Duration, Category)
Dim Appointment As Outlook.AppointmentItem
Dim Attendee As Outlook.Recipient
If Subject <> "" Then
Set Appointment = Calendar.Items.Add
With Appointment
.Start = Start
.Duration = Duration
.ReminderSet = False
.Subject = Subject
.Categories = Category
Set Attendee = Appointment.Recipients.Add("distrubutionlist")
Attendee.Type = olOptional
Appointment.Move Calendar
Appointment.Send
End If
End Sub
Also tried this with the property OptionalAttendees.Add but also there no invites are generated.
You must set the meeting status for the appointment first by using the AppointmentItem.MeetingStatus property which sets an OlMeetingStatus constant specifying the meeting status of the appointment.
Sub CreateAppt()
Dim myItem As Object
Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
Set myItem = Application.CreateItem(olAppointmentItem)
myItem.MeetingStatus = olMeeting
myItem.Subject = "Strategy Meeting"
myItem.Location = "Conference Room B"
myItem.Start = #9/24/2020 1:30:00 PM#
myItem.Duration = 90
Set myRequiredAttendee = myItem.Recipients.Add("Eugene Astafiev")
myRequiredAttendee.Type = olRequired
Set myOptionalAttendee = myItem.Recipients.Add("Kevin Kennedy")
myOptionalAttendee.Type = olOptional
Set myResourceAttendee = myItem.Recipients.Add("Conference Room B")
myResourceAttendee.Type = olResource
myItem.Display
End Sub
Also, you need to pay special attention to the Move method which is called right before the Send one. It moves a Microsoft Outlook item to a new folder and returns an Object value that represents the item that has been moved to the designated folder. So, your code shouldn't call the Move method or handle it gracefully:
movedItem = Appointment.Move Calendar
movedItem.Send
With these two changes worked, thanks, Eugene.
The working code reads:
Sub DoOne(Calendar, Subject, Start, Duration, Category)
Dim Appointment As Outlook.AppointmentItem
Dim Attendee As Outlook.Recipient
If Subject <> "" Then
Set Appointment = Calendar.Items.Add
With Appointment
.MeetingStatus = olMeeting
.Start = Start
.Duration = Duration
.ReminderSet = False
.Subject = Subject
.Categories = Category
End With
Set Attendee = Appointment.Recipients.Add("distributionlist")
Attendee.Type = olOptional
Attendee.Resolve
Appointment.Send
End If
End Sub
I am creating a VBA Macro in Outlook that will copy an existing meeting invite and create a follow up meeting invite. It should be fairly easy since I have all the parts to this puzzle.
My problem is with the body of the invite; all formatting and pictures are lost. For this reason, I need to use the Word Inspector object to preserve any special formatting and images. I figured out the code using Word and recording a macro.
So I have figured out the code for copying text using the Word Inspector, but I am not sure on how to paste it in another invite.
Sub copyPaste()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
On Error Resume Next
Set objOL = Application
If objOL.ActiveInspector.EditorType = olEditorWord Then
Set objDoc = objOL.ActiveInspector.WordEditor
Set objNS = objOL.Session
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Copy
objSel.PasteAndFormat (wdFormatOriginalFormatting)
End If
Set objOL = Nothing
Set objNS = Nothing
End Sub
Please see my current Outlook code:
Sub scheduleFollowUpMeeting()
'Declarations
Dim obj As Object
Dim Sel As Outlook.Selection
'Selecting the Email
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
Set obj = Application.ActiveInspector.currentItem
Else
Set Sel = Application.ActiveExplorer.Selection
If Sel.Count Then
Set obj = Sel(1)
End If
End If
If Not obj Is Nothing Then
MsgBox "The original meeting has been copied." & vbCrLf & "Please kindly update any new details like date/time.", , "Follow Up Meeting - Amit P Shah"
Dim objFollowUp As Outlook.AppointmentItem
Set objFollowUp = Application.CreateItem(olAppointmentItem)
'Copies existing details from original Invite
With objFollowUp
.MeetingStatus = olMeeting
.Subject = "Follow Up: " & obj.Subject
.Body = obj.Body
.Start = Now + 1 'Takes today's date and adds 1 day
.End = DateAdd("n", obj.Duration, .Start)
'Other
.AllDayEvent = obj.AllDayEvent
.BusyStatus = obj.BusyStatus
.Categories = obj.Categories
.Companies = obj.Companies
.ForceUpdateToAllAttendees = obj.ForceUpdateToAllAttendees
.Importance = obj.Importance
.Location = obj.Location
.OptionalAttendees = obj.OptionalAttendees
.ReminderMinutesBeforeStart = obj.ReminderMinutesBeforeStart
.ReminderOverrideDefault = obj.ReminderOverrideDefault
.ReminderPlaySound = obj.ReminderPlaySound
.ReminderSet = obj.ReminderSet
.ReminderSoundFile = obj.ReminderSoundFile
.ReplyTime = obj.ReplyTime
.RequiredAttendees = obj.RequiredAttendees
.Resources = obj.Resources
.ResponseRequested = obj.ResponseRequested
.Sensitivity = obj.Sensitivity
.UnRead = obj.UnRead
.Display
End With
End If
End Sub
Any help would greatly be appreciated. Many thanks in advance!
I'm not a specialist on this subject but i used to work and manipulate Outlook's AppointmentItem in C# and that's how i see the thing.
Actually, if you try to copy the body of a meeting on another meeting, like you said, you will lose all the special formating, images, etc.
The new body will only contain the caracters without format.
I think you can't put formatted text on the body property, you have to use the rtfbody property or like you did when you copy the body of your original appointment, use the WordEditor property in the Inspector object.
So, try to use the WordEditor of the new Item you're creating (like you did to take the original content) and to add content in it.
That's what i had to do for putting formatted text in the body of an AppointmentItem in C#.
I did something like that :
Word.Document myDoc = myItem.GetInspector.WordEditor;
Word.Paragraphs paragraphs = myDoc.Content.Paragraphs;
Word.Paragraph para = paragraphs.Add();
para.Range.Text = yourFormattedTextHere;
After that, you may need to release the variables created, but i'm not sure about that.
My VBA experience is incredibly limited.I have created basic macros for excel primarily by frankensteining multiple macros I find online together.
Here's what I am looking to do. Every morning I send out an email to a list of 200 customers, I open the new message from a list and the message auto populates (as it is a signature). Currently I then go through all these emails and add my subject and BCC. Could I possibly create a macro to open all of these emails, add my BCC, add my subject, and then send the emails.
Any and all help is much appreciated.
The following code defines an instance of Outlook.Application, and sets up a MailItem ready for sending. It uses a Dictionary object called EmailData to hold the various bits of info to populate To, BCC etc but those can be replaced with your own strings etc. I've pulled this from a function I wrote and made it a little more generic:
Public Function OL_SendMail()
Dim bOpenedOutlook, sComputer, iLoop, iAccount, sAttachArray, sAttachment
bOpenedOutlook = False
sComputer = "."
Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
If colItems.Count = 0 Then
' Outlook isn't open, logging onto it...
oNamespace.Logon "Outlook",,False,True
bOpenedOutlook = True
End If
Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
If EmailData("SendFrom") = "" Then
' default to first email account the user has access to
iAccount = 1
Else
' Checking to see if the account to send from is accessible by this user...
iAccount = 0
For iLoop = 1 To oOutlook.Session.Accounts.Count
If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
iAccount = iLoop
Exit For
End If
Next
If iAccount = 0 Then
sErrorMsg = "Cannot send email from specified account: " & EmailData("SendFrom") & " as this user doesn't appear to have access to it in Outlook!"
OL_SendMail = False
Exit Function
End If
End If
Dim oMailItem : Set oMailItem = oOutlook.CreateItem(olMailItem)
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
.To = EmailData("To")
.CC = EmailData("CC")
.BCC = EmailData("BCC")
.Subject = EmailData("Subject")
.Body = EmailData("Body")
sAttachArray = Split(EmailData("AttachmentPaths"), ";")
For Each sAttachment In sAttachArray
.Attachments.Add(sAttachment)
Next
.Recipients.ResolveAll
.Display ' debug mode - uncomment this to see email before it's sent out
End With
'Mail Item created and ready to send
'oMailItem.Send ' this is commented out so the mail doesn't auto send, allows checking of it!!
Set oMailItem = Nothing
Set oNamespace = Nothing
If bOpenedOutlook Then
'oOutlook.Quit
End If
Set oOutlook = Nothing
Set colItems = Nothing
Set oWMIService = Nothing
OL_SendMail = True
End Function
I need to add bcc recipients to an email loaded from a template. The recipients should be all of the contacts in a certain category. I have the following so far, except it is extremely inefficient and causes Outlook to become unresponsive:
Sub Distribute_Newsletter()
Set newItem = Application.CreateItemFromTemplate("P:\Subscription Templates\subscription template.oft")
newItem.Display
Set oNS = Application.GetNamespace("MAPI")
Set oContacts = oNS.Folders(1).Folders("Contacts")
Dim emailAddress As String
For Each oContactItem In oContacts.Items
If oContactItem.Class = olContact Then
emailAddress = oContactItem.Email1Address
If Not emailAddress = "" Then 'And oContactItem.Categories
Set objRecip = newItem.Recipients.Add(emailAddress)
objRecip.Type = olBCC
End If
End If
Next
Set oNS = Nothing
Set oContacts = Nothing
Set objRecip = Nothing
Set newItem = Nothing
End Sub
What I ended up doing was moving newItem.Display down to just before Set newItem = Nothing. This may not be the most efficient solution, but it gets the job done without causing a crash.