I want to add an appointment to a shared Outlook calendar. I know how to add to other people's calendars from MS Access, but I'm having trouble with shared calendars. The creator of the calendar also has their own personal calendar. All of my previous attempts have just added to their personal calendar.
Here's my code... I've tried gathering code on various websites and I'm just stuck. I appreciate any help.
Private Sub Add_to_Shared_Calendar_Click()
Dim outMail As Outlook.AppointmentItem
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder 'get name of other persons folder
Dim objRecip As Outlook.Recipient 'other persons name
Dim strName As String 'the name or email of the persons folder
Dim objAppt As Outlook.AppointmentItem
Dim objApp As Outlook.Application
On Error Resume Next
' name of person whose Calendar you want to use - right?
strName = "John Smith - Project Name Shared Calendar"
Set objNS = objApp.GetNamespace("MAPI")
Set objRecip = objNS.CreateRecipient(strName)
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set outMail = Outlook.CreateItem(olAppointmentItem)
outMail.Subject = "test"
outMail.Location = ""
outMail.MeetingStatus = olMeeting
outMail.Start = Me.dateofevent
outMail.End = Me.TimeofEvent
outMail.RequiredAttendees = strName
outMail.Body = "test message"
outMail.Send
Set outMail = Nothing
End Sub
Replace the lines
outMail = Outlook.CreateItem(olAppointmentItem)
...
outMail.Send
with
outMail = objFolder.Items.Add
...
outMail.Save
Related
I am trying to create a tool that both acts on new emails while Outlook is open as well as on emails received while the Outlook application is closed.
This is what I have so far:
-One sub that creates a note item upon quitting the app.
-One sub that filters emails in the inbox by the their received time.
The second sub is working when I debug (but also infinitely loops and reprocesses the new emails over and over), but does not work (as in does not take any action on the new emails) when I launch the application, expecting the startup event to trigger the sub.
Microsoft Outlook Objects/"ThisOutlookSession"):
Option Explicit
Private StartupTrigger As SaveAttachment1
Private ShutdownTrigger As Class2
Private Sub Application_Startup()
Set StartupTrigger = New SaveAttachment1
StartupTrigger.SaveAttachment1_Initialize
StartupTrigger.Process_New_Items
End Sub
Private Sub Application_Quit()
Set ShutdownTrigger = New Class2
ShutdownTrigger.ExitApp
End Sub
Class Modules:
Class2
Public Sub ExitApp()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olNoteIt As Outlook.NoteItem
Dim myFol As Outlook.Folder
Dim myFilter As String
Dim i As Object
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set myFol = olNS.GetDefaultFolder(olFolderNotes) '.Folders("Attachment Filters")
myFilter = "[Subject] = 'App Close Time'"
For Each i In myFol.Items.Restrict(myFilter)
i.Delete
Next i
Set olNoteIt = olApp.CreateItem(olNoteItem)
With olNoteIt
.Body = "App Close Time"
'.Move myFol
End With
olNoteIt.Save
End Sub
SaveAttachment1
Option Explicit
Public WithEvents olItems As Outlook.Items
Public Sub SaveAttachment1_Initialize()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Folders("User ID (DMs) - Wells Fargo").Items
End Sub
Public Sub Process_New_Items()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim filterString As String
Dim olFol As Outlook.Folder
Dim i As Object
Dim olmi As Outlook.MailItem
Dim cfilter As Object
Dim my_olMail As MailItem
Dim dmi As MailItem
Dim utcdate As Date
Dim filterfolder As Outlook.Folder
Dim SMTPAddress As String
Dim olAtt As Outlook.Attachment
Dim fso As Object
Dim olAttFilter As String
Dim timeFol As Outlook.Folder
Dim lastclose As String
Dim timeFilter As String
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set filterfolder = olNS.GetDefaultFolder(olFolderContacts).Folders("FilterContacts")
Set dmi = olApp.CreateItem(olMailItem)
Set timeFol = olNS.GetDefaultFolder(olFolderNotes)
timeFilter = "[Subject] = 'App Close Time'"
For Each i In timeFol.Items.Restrict(timeFilter)
lastclose = i.CreationTime
Next i
utcdate = dmi.PropertyAccessor.LocalTimeToUTC(lastclose)
filterString = "#SQL=""urn:schemas:httpmail:datereceived"" >= '" & Format(utcdate, "dd mmm yyyy hh:mm") & "'"
Set fso = CreateObject("Scripting.FileSystemObject")
Set olFol = olNS.GetDefaultFolder(olFolderInbox)
For Each i In olFol.Items.Restrict(filterString)
If TypeName(i) = "MailItem" Then
If i.SenderEmailType = "EX" Then
SMTPAddress = i.Sender.GetExchangeUser.PrimarySmtpAddress
Else
SMTPAddress = i.SenderEmailAddress
End If
For Each cfilter In filterfolder.Items
If SMTPAddress = cfilter.JobTitle Then
If InStr(1, LCase(i.Subject), cfilter.BusinessTelephoneNumber) <> 0 Then
For Each olAtt In i.Attachments
If InStr(1, LCase(olAtt.FileName), cfilter.HomeTelephoneNumber) <> 0 Then
olAttFilter = fso.GetExtensionName(olAtt.FileName)
Select Case olAttFilter
Case cfilter.BusinessFaxNumber
olAtt.SaveAsFile cfilter.MobileTelephoneNumber & "\" & olAtt.FileName
Case Else
End Select
Else: End If
Next olAtt
Else: End If
Else: End If
Next cfilter
End If
Next i
End Sub
The "Process_New_Items()" sub is admittedly a mess, but essentially, it is referencing an Outlook contact item and uses the different fields of the contact item to filter the new emails, and then save the attachment if the email meets all the filter criteria.
Thanks!
Adam
acts on new emails while Outlook is open as well as on emails received while the Outlook application is closed
First, to handle new emails I'd recommend using the Application.NewMailEx event which is fired when a new message arrives in the Inbox and before client rule processing occurs. Use the Entry ID represented by the EntryIDCollection argument to call the NameSpace.GetItemFromID method and process the item. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem.
Another possible alternative is to using ItemAdd event on the Inbox folder.
You may find the following series of articles helpful:
Outlook NewMail event unleashed: the challenge (NewMail, NewMailEx, ItemAdd)
Outlook NewMail event: solution options
Outlook NewMail event and Extended MAPI: C# example
Outlook NewMail unleashed: writing a working solution (C# example)
Second, when Outlook is closed the OOM is useless.
Our email system is being updated to Exchange 365. I have a database that was adding calendar events (employee time off) to a public folder.
Well, the updated Exchange does not use public folders. So, we created a user and shared the calendar, and now I'm trying to figure out the code to add/change/delete the event to/from another user's calendar through Access 2016 (and 2012 hopefully).
The code below is me just trying to figure out how to add so has no error checking. In fact, I created a database just for this.
I did figure out how to add it to my own calendar, but it will not work adding it to the new Exchange 365 user calendar. Here is my code:
Private Sub Command15_Click()
Dim outMail As Outlook.AppointmentItem
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder 'get name of other persons folder
Dim objRecip As Outlook.Recipient 'other persons name
Dim strName As String 'the name or email of the persons folder
Dim objAppt As Outlook.AppointmentItem
Dim objApp As Outlook.Application
On Error Resume Next
' name of person whose Calendar you want to use - right
strName = "janet 2"
Set objNS = objApp.GetNamespace("MAPI")
Set objRecip = objNS.CreateRecipient(strName)
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)
'Set outMail = Outlook.CreateItem(olAppointmentItem)
Set outMail = objFolder.Items.Add
outMail.Subject = "test"
outMail.Location = ""
outMail.MeetingStatus = olMeeting
outMail.Start = Me.BegDate
outMail.End = Me.BegTime
outMail.RequiredAttendees = strName
outMail.Body = "test message"
outMail.Save
'Set outMail = Nothing
End Sub
I got it to work (sort of). I changed back Set OutMail to what I originally had:
Set OutMail = Outlook.CreateItem(olAppointmentItem)
And I changed Outmail.Save to Outmail.Send.
It now puts it in the other user's calendar, but as unaccepted. I need it to go in as Accepted. I'm going to research this now.
Whole code that works:
Dim outMail As Outlook.AppointmentItem ' meeting or one-time appointment in Calendar folder
Dim objNS As Outlook.NameSpace ' accessing data sources owned by other users
Dim objFolder As Outlook.MAPIFolder 'get name of other persons folder
Dim objRecip As Outlook.Recipient ' Other persons name
Dim strName As String ' the name or email of the persons folder
Dim objAppt As Outlook.AppointmentItem
Dim objApp As Outlook.Application
'name of person whose calendar you want to use
strName = "ICT Time Off"
Set objApp = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Set objNS = objApp.GetNamespace("MAPI")
Set objRecip = objNS.CreateRecipient(strName)
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)
'Set outMail = Outlook.CreateItem(olAppointmentItem)
Set outMail = objFolder.Items.Add
outMail.Subject = "test"
outMail.Location = ""
outMail.MeetingStatus = olMeeting
outMail.Start = Me.BegDate
outMail.End = Me.EndDate
outMail.RequiredAttendees = strName
outMail.Body = "test message"
outMail.Save
I would like to save and share important items across user accounts running on an Exchange 2016 server. This is setup via Public Folders on the server.
How do I specify the appointment items created go to the folder in the root public folder that is designated for calendar items?
I created all the necessary public folder items on the Exchange 2016 server and have them appearing across multiple accounts that have been designated the required permissions.
I have the appointment item populated with some basic information and I would like it to go to said folder once the user populates any additional fields and clicks the save/send button.
The folder structure for the public folders:
All Public Folders
Company Name sub-folder (Public Folder Mailbox)
Mail
Contacts
Calendars
Public Sub CreateAppointment()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objMsg As Outlook.MailItem 'Message Object
Dim objCalAppt As Outlook.AppointmentItem
Dim objPublicFolderRoot As Outlook.Folder
Dim objDKRRFolder As Outlook.Folder
Dim objApptFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objCalAppt = Application.CreateItem(olAppointmentItem)
Set objMsg = Application.ActiveExplorer().Selection(1)
Set objPublicFolderRoot = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Set objCompanyFolder = objPublicFolderRoot.Folders("Company_Shared")
Set objApptFolder = objCompanyFolder.Folders("Calendars")
With objCalAppt
.MeetingStatus = olNonMeeting 'Not an invitation
.Subject = objMsg.Subject
.Start = objMsg.SentOn
.Duration = 120
End With
objCalAppt.Display
End Sub
If I manually send/save the item, it does not appear in the folder, and it also doesn't appear in the user's calendar.
Instead of creating a "lonely" appointment item, try to create an additional item within the appropriate calendar instead:
Public Sub CreateAppointment()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objMsg As Outlook.MailItem 'Message Object
Dim objCalAppt As Outlook.AppointmentItem
Dim objPublicFolderRoot As Outlook.Folder
Dim objCompanyFolder As Outlook.Folder
Dim objApptFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objMsg = Application.ActiveExplorer().Selection(1)
Set objPublicFolderRoot = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Set objCompanyFolder = objPublicFolderRoot.Folders("Company_Shared")
Set objApptFolder = objCompanyFolder.Folders("Calendars")
Set objCalAppt = objApptFolder.Items.Add(olAppointmentItem)
With objCalAppt
.MeetingStatus = olNonMeeting 'Not an invitation
.Subject = objMsg.Subject
.Start = objMsg.SentOn
.Duration = 120
End With
objCalAppt.Display
End Sub
As the code row Set objMsg = Application.ActiveExplorer().Selection(1) only works, if the user currently selected an email item, I suggest to verify that additionally:
Dim objSel As Outlook.Selection
Set objSel = Application.ActiveExplorer.Selection
If objSel.Count > 0 Then
If objSel(1).Class = olMail Then
Set objMsg = objSel(1)
Else
MsgBox "Works only on selected email."
End If
Else
MsgBox "Works only on selected email."
End If
I have code that looks for a specific subject line in an email on Outlook and grabs the attachment from the email.
We merged our emails with a corporate buyout and updated our Microsoft accounts to Office 365. Aside from this, my original VBA code should work since it doesn't look for any specific email folder. All references for Outlook are checked.
I get "nothing" for olMi and it exits the if statement.
Function Report()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim olFldr As MAPIFolder
Dim olItms As Items
Dim olMi As MailItem
Dim olEmail As Outlook.MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim wB As Workbook
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set olEmail = olApp.CreateItem(olMailItem)
Set rng = Nothing
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
subj = "Scheduled Report - Instructor List"
Set olMi = olItms.Find("[Subject] = " & Chr(34) & subj & Chr(34))
''___> I get "OlMi = Nothing" here and it used to work
If Not (olMi Is Nothing) Then
For Each olAtt In olMi.Attachments
olAtt.SaveAsFile "C:\Users\Instructor\Desktop\temp\Instructor_Master.xls"
Next olAtt
Else
End If
End Function
The default mailbox can change.
To determine the current default mailbox.
Option Explicit
Private Sub defaultAfterUpgrade()
Dim defInbx As Folder
Dim defMailbox As Folder
Set defInbx = Session.GetDefaultFolder(olFolderInbox)
Set defMailbox = defInbx.Parent
Debug.Print "The default mailbox is: " & defMailbox.name
End Sub
As you found, when this occurs you have to change to the long version of referencing an inbox that includes the mailbox name.
I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder