I've created two macros. Both run when VB Editor is open, but not anywhere else. In the first macro I assigned a button to it, but it doesn't run. The second doesn't run from the macro dropdown. Any thoughts? Using desktop version of Outlook for MS 365 MS, 64-bit. Macro security is set to Enable all macros.
Code #1 - Purpose: To change category of Focus Time appointments
Option Explicit
' Change Insight's Focus Time Appointments
' Source: Change Insight's Focus Time Appointments
Public Sub ChangeInsights()
Dim calFolder As folder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter As String
Dim Appt As AppointmentItem 'Object
Dim mystart As Date
mystart = Date
Set calFolder = Session.GetDefaultFolder(olFolderCalendar)
Set CalItems = calFolder.Items
'Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
On Error Resume Next
sFilter = "[Start] >='" & Format(mystart, "m/d/yy") & "' AND [Subject] = Focus Time"
Set ResItems = CalItems.Restrict(sFilter)
'Loop through the items in the collection.
For Each Appt In ResItems
With Appt
.Categories = "Deep Work"
'.ReminderSet = False
'.BusyStatus = olTentative
.Save
End With
Next
Set Appt = Nothing
End Sub
Code #2 - Purpose: To delete email address in the body of a forwarded email.
Sub DeleteTos()
Dim outNS As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim strTo As String
Dim strSubject As String
strTo = "To:"
strSubject = "Subject"
Set outNS = Application.GetNamespace("MAPI")
Set Item = GetCurrentItem()
Start = InStr(1, Item.body, strTo)
Done = InStr(1, Item.body, strSubject)
Remove = Done - Start
emails = Mid(Item.body, Start, Remove)
With Item
.body = Replace(Item.body, emails, "")
End With
Set outNS = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.currentItem
End Select
Set objApp = Nothing
End Function
Thanks!
Code #1 - Purpose: To change category of Focus Time appointments
Option Explicit
' Change Insight's Focus Time Appointments
' Source: Change Insight's Focus Time Appointments
Public Sub ChangeInsights()
Dim calFolder As folder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter As String
Dim Appt As AppointmentItem 'Object
Dim mystart As Date
mystart = Date
Set calFolder = Session.GetDefaultFolder(olFolderCalendar)
Set CalItems = calFolder.Items
'Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
On Error Resume Next
sFilter = "[Start] >='" & Format(mystart, "m/d/yy") & "' AND [Subject] = Focus Time"
Set ResItems = CalItems.Restrict(sFilter)
'Loop through the items in the collection.
For Each Appt In ResItems
With Appt
.Categories = "Deep Work"
'.ReminderSet = False
'.BusyStatus = olTentative
.Save
End With
Next
Set Appt = Nothing
End Sub
Code #2 - Purpose: To delete email address in the body of a forwarded email.
Sub DeleteTos()
Dim outNS As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim strTo As String
Dim strSubject As String
strTo = "To:"
strSubject = "Subject"
Set outNS = Application.GetNamespace("MAPI")
Set Item = GetCurrentItem()
Start = InStr(1, Item.body, strTo)
Done = InStr(1, Item.body, strSubject)
Remove = Done - Start
emails = Mid(Item.body, Start, Remove)
With Item
.body = Replace(Item.body, emails, "")
End With
Set outNS = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.currentItem
End Select
Set objApp = Nothing
End Function
Thanks!