Deleting appointments from shared Outlook calendar - excel

I want to clear a shared calendar.
I have a delete method that works in my Outlook calendar however it doesn't clear the shared calendar.
Private Sub DeleteAllAppointments()
Dim olkApp As Object, _
olkSession As Object, _
olkCalendar As Object, _
olkItem As Object, _
intIndex As Integer
Set olkApp = CreateObject("Outlook.Application")
Set olkSession = olkApp.Session
olkSession.Logon
Set olkCalendar = olkSession.GetDefaultFolder(olFolderCalendar)
For intIndex = olkCalendar.Items.Count To 1 Step -1
Set olkItem = olkCalendar.Items.Item(intIndex)
olkItem.Delete
Next
Set olkItem = Nothing
Set olkCalendar = Nothing
olkSession.Logoff
Set olkSession = Nothing
Set olkApp = Nothing
End Sub
This is where the method fails
Set olkCalendar = olkSession.GetDefaultFolder(olFolderCalendar)
Is this is a folder path issue?

This is how I did it.
Sub Delete_SharedCal_History()
DeleteCal_Appts "Office Calendar", "1/9/2001", "0:00:01", "12/31/2013", "23:59:59"
End Sub
Sub DeleteCal_Appts(sCalendarName As String, ap_dateStart As String, ap_startTime As String, ap_dateEnd As String, ap_endTime As String)
' Specified Shared Calendar - Delete all events in specified Date Range
' Author: Frank Zakikian
Dim objAppointment As AppointmentItem
Dim objAppointments As Items
Dim objNameSpace As NameSpace
Dim objRecip As Recipient
Dim nInc As Integer
Dim sFilter As Variant
Dim dtStartTime As Date, dtEndTime As Date
dtStartTime = CDate(ap_dateStart & " " & ap_timeStart)
dtEndTime = CDate(ap_dateEnd & " " & ap_timeEnd)
Set objNameSpace = Application.GetNamespace("MAPI")
'next line would be for use of personal calendar object..
'Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
Set objRecip = objNameSpace.CreateRecipient(sCalendarName)
objRecip.Resolve
'Debug.Print objRec.AddressEntry
Set objAppointments = objNameSpace.GetSharedDefaultFolder(objNameSpace.CreateRecipient("Akron Chambers Calendar"), olFolderCalendar).Items
sFilter = "[Start] > '" & Format(dtStartTime, "ddddd h:nn AMPM") & _
"' And [Start] < '" & Format(dtEndTime, "ddddd h:nn AMPM") & "'"
objAppointments.Sort "[Start]", False
Debug.Print "Total Items at begin: " & objAppointments.Count 'dev. fyi
Set objAppointment = objAppointments.Find(sFilter)
While TypeName(objAppointment) <> "Nothing"
'If MsgBox(objAppointment.Subject & vbCrLf & "Delete " & objRec.AddressEntry & " item now? ", vbYesNo, "Delete Calendar Item") = vbYes Then
objAppointment.Delete
nInc = nInc + 1
'End If
Set objAppointment = objAppointments.FindNext
Wend
MsgBox "Deleted " & nInc & " calendar items.", vbInformation, "Delete done"
Debug.Print "Total Items at finish: " & objAppointments.Count 'dev. fyi
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub

olkSession.GetDefaultFolder(olFolderCalendar) would retrieve your default Calendar folder. You need to either use olkSession.GetSharedDefaultFolder(someRecipient, olFolderCalendar) (where someRecipient is returned by olkSession.CreateRecipient) or open the appropriate store from the Namespace.Stores collection (assuming the delegate mailbox is already there) and call Store.GetDefaultFolder.

Related

Get Emails Not Replied from Shared mailbox VBA

I am trying to Extract Emails from Shared mailbox which i am not Owner i have access to send on behalf
but Unable to save search and If any one can assist to Get Email in last 24hours Which are not Replied from Shared Mailbox
Below is Code Which I was Able to do it
Sub CreateSearchFolder_AllNotRepliedEmails()
Dim OutlookApp As Outlook.Application
Dim strScope As String
Dim OutlookNamespace As NameSpace
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Outlook.Search
Dim objOwner As Outlook.Recipient
Dim Folder As MAPIFolder
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
'If objOwner.Resolved Then
'Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox).FolderPath & "'"
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Set objSearch = Outlook.Application.AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True)
'Save the search folder
objSearch.Save ("Sd email not Replied")// Tried This But Not working
MsgBox "Search folder is created successfully!", vbInformation + vbOKOnly, "Search Folder"
End Sub
Kindly advise for Solution
There is no reason to use (asynchronous) AdvancedSearch (unless you want the list saved as a search folder); use (synchronous) Items.Restrict:
filter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
set folder = Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
set notRepliedOrForwardedItems = folder.Items.Restrict(filter)
This demonstrates processing search results without a search folder.
After a Eureka moment.
Option Explicit
' Code in ThisOutlookSession
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal objSearch As Search)
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch
' Code should be in a class module such as ThisOutlookSession
Debug.Print "The AdvancedSearchComplete Event fired"
If objSearch.Tag = "AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701" Then
'm_SearchComplete = True` ' Use Option Explicit.
blnSearchComp = True
End If
End Sub
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701()
' Code in ThisOutlookSession
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & _
"AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Fewer results than above.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True, _
Tag:="AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701")
' 2022-07-01 Eureka!
blnSearchComp = False
' Otherwise remains True.
' Search would work once until Outlook restarted.
While blnSearchComp = False
DoEvents
'Code should be in a class module such as ThisOutlookSession
Debug.Print "Wait a few seconds. Ctrl + Break if needed."
Wend
Debug.Print "objSearch.results.count: " & objSearch.results.count
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' Errors in the sample code:
' Typo blnSearchComp = True - use Option Explicit
' Syntax error Set sch = Application.AdvancedSearch(strS, strF, , "Test") - Missing comma
' Before each search: blnSearchComp = False - Else permanently True after first run
'
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
Else
Debug.Print "No items found."
End If
Debug.Print "Done."
End Sub
Leaving this in case there are even more pitfalls in AdvancedSearch.
Option Explicit
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder()
' Code in Outlook
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" _
& Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Deleted question indicates other options
' https://stackoverflow.com/questions/19381504/determine-whether-mail-has-been-replied-to
' 102 "Reply to Sender"
' 103 "Reply to All"
' 104 "Forward"
' 108 "Reply to Forward"
' Fewer results than above. NULL may be correct.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True)
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
'
' I have to use a workaround for AdvancedSearchComplete.
' I delay to allow the search to complete.
' Resist using this workaround in production code.
'Debug.Print "rsts.count: " & rsts.count
If rsts.count = 0 Then
Dim waitTime As Long
Dim delay As Date
moreDelay:
Debug.Print " Delay invoked."
waitTime = 1 ' in seconds - adjust as needed
Debug.Print vbCr & "Wait start: " & Now
delay = DateAdd("s", waitTime, Now)
Debug.Print "Wait until: " & delay
Do Until Now > delay
DoEvents
Loop
'Debug.Print "rsts.Count: " & rsts.count
If rsts.count = 0 Then
Debug.Print "No mail found or delay too short."
If MsgBox("No mail found or delay too short. Allow more time?", vbYesNo) = vbYes Then
GoTo moreDelay
Else
Debug.Print "No items found. / Search failure acknowledged."
End If
Else
Debug.Print " Delay successful."
GoTo processItems
End If
Else
Debug.Print "Delay not required."
GoTo processItems
End If
Debug.Print "Done."
Exit Sub
processItems:
' ---> After search is confirmed complete with AdvancedSearchComplete <---
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
End If
Debug.Print "Done."
End Sub

How to create emails from Excel table?

I have a table in Excel. It is built as follows:
|Information on food|
|date: April 28th, 2021|
|Person|Email|Apples|Bananas|Bread|
|------|-----|------|-------|-----|
|Person_A|person_A#mailme.com|3|8|9|
|Person_B|person_B#mailme.com|10|59|11|
|Person _C|person_C#maime.com|98|12|20|
There is also a date field in the table. For a test, this could be set to todays date.
Based on this information, I am looking for a VBA code which prepares an email to each of the listed persons and is telling them what they have eaten on the specific date.
I need to access several fields in the table, and at the same time loop through the email addresses. Then I would like VBA to open Outlook and prepare the emails. Ideally not send them so I can take a final look before I send the mails.
It would be fine to access certain cells specifically via ranges etc. I am using Excel/Outlook 2016.
How can this be achieved in VBA?
Assuming the data is a named table and title/date are above the corner of the table as shown in your example. Also all the rows of the table have valid data. The emails are prepared and shown but not sent (unless you change the code where shown).
Option Explicit
Sub EmailMenu()
Const TBL_NAME = "Table1"
Const CSS = "body{font:12px Verdana};h1{font:14px Verdana Bold};"
Dim emails As Object, k
Set emails = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet, rng As Range
Dim sName As String, sAddress As String
Dim r As Long, c As Integer, s As String, msg As String
Dim sTitle As String, sDate As String
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.ListObjects(TBL_NAME).Range
sTitle = rng.Cells(-1, 1)
sDate = rng.Cells(0, 1)
' prepare emails
For r = 2 To rng.Rows.Count
sName = rng.Cells(r, 1)
sAddress = rng.Cells(r, 2)
If InStr(sAddress, "#") = 0 Then
MsgBox "Invalid Email: '" & sAddress & "'", vbCritical, "Error Row " & r
Exit Sub
End If
s = "<style>" & CSS & "</style><h1>" & sDate & "<br>" & sName & "</h1>"
s = s & "<table border=""1"" cellspacing=""0"" cellpadding=""5"">" & _
"<tr bgcolor=""#ddddff""><th>Item</th><th>Qu.</th></tr>"
For c = 3 To rng.Columns.Count
s = s & "<tr><td>" & rng.Cells(1, c) & _
"</td><td>" & rng.Cells(r, c) & _
"</td></tr>" & vbCrLf
Next
s = s & "</table>"
' add to dictonary
emails.Add sAddress, Array(sName, sDate, s)
Next
' confirm
msg = "Do you want to send " & emails.Count & " emails ?"
If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
' send emails
Dim oApp As Object, oMail As Object, ar
Set oApp = CreateObject("Outlook.Application")
For Each k In emails.keys
ar = emails(k)
Set oMail = oApp.CreateItem(0)
With oMail
.To = CStr(k)
'.CC = "email#test.com"
.Subject = sTitle
.HTMLBody = ar(2)
.display ' or .send
End With
Next
oApp.Quit
End Sub

Get outlook email items with excel VBA, restrict by date

I wrote the below code and it works perfect when I want to extract the outlook email items in my excel sheet, but it does not work when I want to get the emails that were received on a certain date:
Sub getMail()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As Items
Dim olItem As Variant
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder 'Pick folder
Set olItems = olInboxFolder.Items
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
ThisWorkbook.Worksheets("Output").Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
ActiveSheet.Range("E2", Range("E2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
i = 1
sFilter = InputBox("Enter Date")
FilterString = "[ReceivedTime] > sFilter "
For Each olItem In olItems.Restrict(FilterString)
' MailItem
If olItem.Class = olMail Then
Set mi = olItem
Debug.Print mi.ReceivedTime
ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).ReceivedTime
If olItems(i).SenderEmailType = "SMTP" Then
ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ElseIf olItems(i).SenderEmailType = "EX" Then
ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).Sender.GetExchangeUser.PrimarySmtpAddress
End If
ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets("Output").Cells(i + 1, "D").Value = olItems(i).Body
i = i + 1
On Error Resume Next
' ReportItem
ElseIf olItem.Class = olReport Then
ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = _
olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E") 'PR_DISPLAY_TO
ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
i = i + 1
End If
Next olItem
ThisWorkbook.Worksheets("Output").Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
For example I want to get all the emails that were sent starting with 08/16/2020 date, Or get all the emails on a certain date range.
Private Sub getMail_InputBoxDate()
Dim olNS As namespace
Dim olFilterFolder As Folder
Dim olItems As Items
Dim olItem As Object
Dim mi As mailItem
Dim filterString As String
Dim sDate1 As String
Dim filterString1 As String
Dim sDate2 As String
Dim filterString2 As String
Dim olItemsRes As Items
Set olNS = GetNamespace("MAPI")
Set olFilterFolder = olNS.PickFolder 'Pick folder
Set olItems = olFilterFolder.Items
olItems.Sort "[ReceivedTime]", True
Debug.Print vbCr & "olItems.Count: " & olItems.Count
sDate1 = InputBox("Enter Start Date", , "2020-09-14")
'Debug.Print sDate1
sDate1 = Format(sDate1 & " 00:00 AM", "DDDDD HH:NN")
Debug.Print vbCr & "sDate1: " & sDate1
' Single quotes around variable.
filterString1 = "[ReceivedTime] >= '" & sDate1 & "'"
Debug.Print " filterString1: " & filterString1
Set olItemsRes = olItems.Restrict(filterString1)
Debug.Print " olItemsRes.Count: " & olItemsRes.Count
sDate2 = InputBox("Enter date, one day after desired range.", , "2020-09-15")
'Debug.Print sDate2
sDate2 = Format(sDate2 & " 00:00 AM", "DDDDD HH:NN")
Debug.Print vbCr & "sDate2: " & sDate2
' With single quotes around variable.
filterString2 = "[ReceivedTime] < '" & sDate2 & "'"
Debug.Print " filterString2: " & filterString2
' Option 1 - Restrict the previously restricted items
Set olItemsRes = olItemsRes.Restrict(filterString2)
Debug.Print " olItemsRes.Count: " & olItemsRes.Count
Debug.Print
For Each olItem In olItemsRes
' MailItem
If olItem.Class = olMail Then
Set mi = olItem
Debug.Print mi.ReceivedTime & " " & mi.Subject
End If
Next olItem
' Option 2 - Combine two working filters into one
filterString = filterString1 & " AND " & filterString2
Debug.Print vbCr & "filterString combined: " & filterString
' Restrict the original items once
Set olItemsRes = olItems.Restrict(filterString)
Debug.Print "olItemsRes.Count: " & olItemsRes.Count
Debug.Print
For Each olItem In olItemsRes
' MailItem
If olItem.Class = olMail Then
Set mi = olItem
Debug.Print mi.ReceivedTime & " " & mi.Subject
End If
Next olItem
Debug.Print vbCr & "Done."
End Sub
This is Restrict Outlook Items by Date but adds time to the user-input date.

Shared Calendar with Outlook loaded from Citrix

I have the following function in Excel to access shared calendar folders in Outlook and list all certain appointments (identified from its subject) within specified date range.
The code seems doesn't work as expected as Outlook is loaded from Citrix server.
I'm not so sure about this and need somebody's help on how to solve this.
Option Explicit
Function GetColleagueAppointments(dtStartAppt As Date, dtEndAppt As Date, strUserName As String) 'As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose: List down all colleague's client meetings between date range
'
' Inputs: dtStartAppt Start date to search
' dtEndAppt End date to search
' strUserName Colleague calendars to search
'
' Assumptions: * User must have access to the appropriate shared calendars in
' Outlook
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim objOL As New Outlook.Application ' Outlook
Dim objNS As NameSpace ' Namespace
Dim OLFldr As Outlook.MAPIFolder ' Calendar folder
Dim OLAppt As Object ' Single appointment
Dim OLRecip As Outlook.Recipient ' Outlook user name
Dim OLAppts As Outlook.Items ' Appointment collection
Dim oFinalItems As Outlook.Items
Dim strRestriction As String ' Day for appointment
Dim strList() As String ' List of all available timeslots
Dim dtmNext As Date ' Next available time
Dim intDuration As Integer ' Duration of free timeslot
Dim i As Integer ' Counter
Dim lr As Long, r As Long
Dim wb As Workbook
Dim ws As Worksheet
'FastWB True
Set wb = ThisWorkbook
Set ws = wb.Sheets("Meeting List")
Const C_Procedure = "GetColleagueAppointments" ' Procedure name
'This is an enumeration value in context of getDefaultSharedFolder
Const olFolderCalendar As Byte = 9
strRestriction = "[Start] >= '" & _
Format$(dtStartAppt, "mm/dd/yyyy hh:mm AMPM") _
& "' AND [End] <= '" & _
Format$(dtEndAppt, "mm/dd/yyyy hh:mm AMPM") & "'"
' loop through shared Calendar for all Employees in array
Set objNS = objOL.GetNamespace("MAPI")
With ws
On Error Resume Next
Set OLRecip = objNS.CreateRecipient(strUserName)
OLRecip.Resolve
'If OLRecip.Resolved Then
'Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
Set OLFldr = objNS.GetSharedDefaultFolder(OLRecip, olFolderCalendar)
'End If
' calendar not shared
If Err.Number <> 0 Then
'# Employee Date Start End Client Agenda Location
r = Last(1, .Columns("G")) + 1
.Range("F" & r).Value = r - 1 '#
.Range("G" & r).Value = strUserName 'Employee
.Range("H" & r).Value = "Calendar not shared" 'Format(dtStartAppt, "d-mmm-yyyy") 'Date
.Range("I" & r).Value = "Calendar not shared" 'Start
.Range("J" & r).Value = "Calendar not shared" 'End
.Range("K" & r).Value = "Calendar not shared" 'Client
.Range("L" & r).Value = "Calendar not shared" 'Agenda
.Range("M" & r).Value = "Calendar not shared" 'Location
GoTo ExitHere
End If
'On Error GoTo ErrHandler
Set OLAppts = OLFldr.Items
' Sort the collection (required by IncludeRecurrences)
OLAppts.Sort "[Start]"
' Make sure recurring appointments are included
OLAppts.IncludeRecurrences = True
' Filter the collection to include only the day's appointments
Set OLAppts = OLAppts.Restrict(strRestriction)
'Construct filter for Subject containing 'Client'
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
strRestriction = "#SQL=" & Chr(34) & PropTag _
& "0x0037001E" & Chr(34) & " like '%Client%'"
' Filter the collection to include only the day's appointments
Set OLAppts = OLAppts.Restrict(strRestriction)
' Sort it again to put recurring appointments in correct order
OLAppts.Sort "[Start]"
With OLAppts
' capture subject, start time and duration of each item
Set OLAppt = .GetFirst
Do While TypeName(OLAppt) <> "Nothing"
r = Last(1, .Columns("G")) + 1
'- Client - HSBC - Trade Reporting
'# Employee Date Start End Client Agenda Location
If InStr(LCase(OLAppt.Subject), "client") > 0 Then
strList = Split(OLAppt.Subject, "-")
.Range("F" & r).Value = r - 1
.Range("G" & r).Value = strUserName
.Range("H" & r).Value = Format(dtStartAppt, "d-mmm-yyyy")
.Range("I" & r).Value = OLAppt.Start
.Range("J" & r).Value = OLAppt.End
.Range("K" & r).Value = Trim(CStr(strList(1)))
.Range("L" & r).Value = Trim(CStr(strList(2)))
.Range("J" & r).Value = OLAppt.Location
End If
Set OLAppt = .GetNext
Loop
End With
End With
ExitHere:
On Error Resume Next
Set OLAppt = Nothing
Set OLAppts = Nothing
Set objNS = Nothing
Set objOL = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description
Resume ExitHere
End Function
Remove the first On Error Resume Next (the one below With ws) and post the line where the code is failing.
Also, you mentioned Outlook is run on a Citrix server. I hope you're running this script in the same instance where Outlook is running otherwise I'm not sure how you expect communication with the Outlook instance would happen.
I also hope you do have access to the shared calendar, something you didn't explicitly mention.

Outlook VBA: Save a file from a link in outlook to a specific folder on my computer

I get a report everyday in the form on a link (for an excel file) something like-
<<\X_Y_Daily_2018-08-21-08-40-45.xlsx>>
which I would like to save on my desktop in a specific folder in outlook after renaming.I am very new to VBA and hunted for something like this but to no avail.
I already have a rule to save all these emails to a specific folder called "Daily Track". Please let me know whether this is possible, really would appreciate all help to make me feel less like a data saver all day...
I want to save the file to Y:\BBG\Daily\2018\8. August
This is possible. Iterate the inbox and then get every MailItem. If the MailItem.HTMLBody contains the xls name(X_Y_Daily_2018-08-21-08-40-45.xlsx), use Regex to get the URL then download the file from the url by VBA(Like this):
Just some init code but not the final:
Sub TestOutlook()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, Item As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Dim MessageInfo
Dim Result
Set ws = ActiveSheet '~~> or you can be more explicit using the next line
'Set ws = Thisworkbook.Sheets("YourTargetSheet")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
'Debug.Print eFolder.Name
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set Item = olFolder.Items(i)
'MsgBox Item.Body
'filter (Item)
'If InStr(Item.Subject, "Test download") > 0 Then
' MsgBox "Here"
' MessageInfo = "" & _
' "Sender : " & Item.SenderEmailAddress & vbCrLf & _
' "Sent : " & Item.SentOn & vbCrLf & _
' "Received : " & Item.ReceivedTime & vbCrLf & _
' "Subject : " & Item.Subject & vbCrLf & _
' "Size : " & Item.Size & vbCrLf & _
' "Message Body : " & vbCrLf & Item.Body
' Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
' End If
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Sub filter(Item As Outlook.MailItem)
Dim ns As Outlook.Namespace
Dim MailDest As Outlook.Folder
Set ns = Application.GetNamespace("MAPI")
Set Reg1 = CreateObject("VBScript.RegExp")
Reg1.Global = True
Reg1.Pattern = "(.*Test download.*)"
If Reg1.test(Item.Subject) Then
'Set MailDest = ns.Folders("Personal Folders").Folders("one").Folders("a")
'Item.Move MailDest
MsgBox Item.Body
End If
End Sub

Resources