Dim WithEvents newAppt As Items
Dim WithEvents objPane As NavigationPane
Sub ConvertSelectedMailtoTask()
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objMail In Application.ActiveExplorer.Selection
With objTask
.Subject = objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = "From: " & objMail.Sender & vbCrLf & "Sent: " & objMail.ReceivedTime & vbCrLf & "To: " & objMail.To & vbCrLf & "Subject: " & objMail.Subject & vbCrLf & vbCrLf & Replace(objMail.Body, vbCrLf & vbCrLf, vbCrLf)
.Save
End With
Next
Set objTask = Nothing
Set objMail = Nothing
End Sub
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim Msg$
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.FolderPath & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub
Sub ConvertMailtoTask(Item As Outlook.MailItem)
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
With objTask
.Subject = Item.Subject
.StartDate = Item.ReceivedTime
.Body = "From: " & Item.Sender & vbCrLf & "Sent: " & Item.ReceivedTime & vbCrLf & "To: " & Item.To & vbCrLf & "Subject: " & Item.Subject & vbCrLf & " ------------------------------------------ " & vbCrLf & Item.Body
.Categories = "A - Must Do"
.Save
End With
Set objTask = Nothing
End Sub
Sub ConvertSelectedMailtoAppointment()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Set objAppt = Application.CreateItem(olAppointmentItem)
For Each objMail In Application.ActiveExplorer.Selection
With objAppt
objAppt.Subject = objMail.Subject
objAppt.Start = objMail.ReceivedTime
objAppt.ReminderSet = True
.Body = "From: " & objMail.Sender & vbCrLf & "Sent: " & objMail.ReceivedTime & vbCrLf & "To: " & objMail.To & vbCrLf & "Subject: " & objMail.Subject & vbCrLf & " ------------------------------------------ " & vbCrLf & objMail.Body
objAppt.Save
End With
Next
Set objAppt = Nothing
Set objMail = Nothing
End Sub
Sub AcceptandForward()
Dim oAppt As MeetingItem
Dim cAppt As AppointmentItem
Dim oRequest As MeetingItem
Dim oResponse
Set cAppt = GetCurrentItem.GetAssociatedAppointment(True)
Set oRequest = GetCurrentItem()
Set oAppt = oRequest.Forward
oAppt.Recipients.Add "edward.c-ctr.faulk@faa.gov"
oAppt.Subject = Right(oAppt.Subject, Len(oAppt.Subject - 4))
oAppt.Send
Set oResponse = cAppt.Respond(olMeetingAccepted, True)
oResponse.Send
Set cAppt = Nothing
Set oAppt = Nothing
Set oRequest = Nothing
End Sub
Sub SaveAndDecline()
Dim oAppt As AppointmentItem
Dim cAppt As AppointmentItem
Dim oResponse
Set cAppt = GetCurrentItem.GetAssociatedAppointment(True)
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = "Declined: " & cAppt.Subject
.Start = cAppt.Start
.Duration = cAppt.Duration
.Location = cAppt.Location
.Save
.Delete
End With
Set oResponse = cAppt.Respond(olMeetingDeclined, True)
oResponse.Send
Set cAppt = Nothing
Set oAppt = 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 Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If InStr(1, Item.Body, "attach", vbTextCompare) > 0 Then
If Item.Attachments.count = 0 Then
answer = MsgBox("There's no attachment, send anyway?", vbYesNo)
If answer = vbNo Then Cancel = True
End If
End If
End Sub
Sub ResendSentEmail()
'works in Outlook 2013/2016
Dim myItem As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim objActionsMenu As Office.CommandBarControl
Dim olResendMsg As Outlook.MailItem
' get current item & open if needed
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = Application.ActiveExplorer.Selection.Item(1)
myItem.Display
Case "Inspector"
Set myItem = Application.ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
MsgBox "Could not use current item. Please select or open a single email.", _
vbInformation
GoTo exitproc
End If
' run the resend command
Set objInsp = myItem.GetInspector
objInsp.CommandBars.ExecuteMso ("ResendThisMessage")
' get the opened compose message form & send it
' delete these lines if you don't need to auto-edit or to auto-send it
'Set olResendMsg = Application.ActiveInspector.CurrentItem
' update fields if needed
'olResendMsg.Subject = myItem.Subject & " (resend)"
'olResendMsg.Send
' close orig email
myItem.Close olDiscard
exitproc:
Set myItem = Nothing
Set objInsp = Nothing
Set objActionsMenu = Nothing
Set olResendMsg = Nothing
End Sub
Private Sub objPane_ModuleSwitch(ByVal CurrentModule As NavigationModule)
Dim objModule As TasksModule
Dim objGroup As NavigationGroup
Dim objNavFolder As NavigationFolder
If CurrentModule.NavigationModuleType = olModuleTasks Then
Set objModule = objPane.Modules.GetNavigationModule(olModuleTasks)
Set objGroup = objModule.NavigationGroups("My Tasks")
' Change the 2 to start in a different folder
Set objNavFolder = objGroup.NavigationFolders.Item(1)
objNavFolder.IsSelected = True
End If
Set objNavFolder = Nothing
Set objGroup = Nothing
Set objModule = Nothing
End Sub
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "Notice of Payment made to traveler"
Item.Save
Set myForward = Item.Forward
myForward.Recipients.Add "curt.faulk@gmail.com"
myForward.Send
End Sub
'Adds a link to the currently selected message to the clipboard
Sub AddLinkToMessageInClipboard()
Dim objMail As Outlook.MailItem
Dim doClipboard As New DataObject
'One and ONLY one message muse be selected
If Application.ActiveExplorer.Selection.count <> 1 Then
MsgBox ("Select one and ONLY one message.")
Exit Sub
End If
Set objMail = Application.ActiveExplorer.Selection.Item(1)
doClipboard.SetText "outlook:" + objMail.EntryID + ""
doClipboard.PutInClipboard
End Sub
Sub AddFileNumber()
Dim myOlApp As Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlsel As Outlook.Selection
Dim aItem As Object
Dim x As Integer
Dim iItemsUpdated As Integer
Dim strTemp As String
Dim strFilenum As Variant
Set myOlApp = CreateObject("Outlook.Application")
Set myOlExp = Application.ActiveExplorer
Set myOlsel = myOlExp.Selection
'Show input box
strFilenum = InputBox("Enter the Issue ID Nonce")
' Empty value or cancel button
If strFilenum = False Then Exit Sub
If strFilenum = "" Then Exit Sub
iItemsUpdated = 0
For x = 1 To myOlsel.count
'Working line edited out: strTemp = myOlsel.Item(x).Subject & " (P50 I/IN: " & strFilenum & ")"
strTemp = myOlsel.Item(x).Subject & " (" & strFilenum & ")"
myOlsel.Item(x).Subject = strTemp
iItemsUpdated = iItemsUpdated + 1
myOlsel.Item(x).Save
Next x
MsgBox "Subject prefix updated of " & iItemsUpdated & " of " & myOlsel.count & " Messages"
Set myOlApp = Nothing
End Sub
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = strFolderpath & "\OLAttachments\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Function GetFolder(ByVal FolderPath As String) As Outlook.folder
' Returns an Outlook folder object basing on the folder path
'
Dim TempFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolder_Error
'Remove Leading slashes in the folder path
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TempFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TempFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TempFolder.Folders
Set TempFolder = SubFolders.Item(FoldersArray(i))
If TempFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TempFolder
Set GetFolder = TempFolder
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
Sub Application_Startup()
Set OlItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Sub ConvertSelectedMailtoMUSTDOTask()
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objMail In Application.ActiveExplorer.Selection
With objTask
.Subject = objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = "From: " & objMail.Sender & vbCrLf & "Sent: " & objMail.ReceivedTime & vbCrLf & "To: " & objMail.To & vbCrLf & "Subject: " & objMail.Subject & vbCrLf & vbCrLf & Replace(objMail.Body, vbCrLf & vbCrLf, vbCrLf)
objTask.Categories = "A - Must Do (Today)"
.Save
End With
Next
Set objTask = Nothing
Set objMail = Nothing
End Sub
Sub ConvertSelectedMailtoCouldDoTask()
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objMail In Application.ActiveExplorer.Selection
With objTask
.Subject = objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = "From: " & objMail.Sender & vbCrLf & "Sent: " & objMail.ReceivedTime & vbCrLf & "To: " & objMail.To & vbCrLf & "Subject: " & objMail.Subject & vbCrLf & vbCrLf & Replace(objMail.Body, vbCrLf & vbCrLf, vbCrLf)
objTask.Categories = "C - Could Do (10 Days or More)"
.Save
End With
Next
Set objTask = Nothing
Set objMail = Nothing
End Sub
Sub ConvertSelectedMailtoShouldDoTask()
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objMail In Application.ActiveExplorer.Selection
With objTask
.Subject = objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = "From: " & objMail.Sender & vbCrLf & "Sent: " & objMail.ReceivedTime & vbCrLf & "To: " & objMail.To & vbCrLf & "Subject: " & objMail.Subject & vbCrLf & vbCrLf & Replace(objMail.Body, vbCrLf & vbCrLf, vbCrLf)
objTask.Categories = "B - Should Do (This Workweek)"
.Save
End With
Next
Set objTask = Nothing
Set objMail = Nothing
End Sub
Sub CatorgorizeAsShouldDoTask()
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objTask In Application.ActiveExplorer.Selection
With objTask
objTask.Categories = "B - Should Do (This Workweek)"
.Save
End With
Next
Set objTask = Nothing
End Sub
Sub CatorgorizeAsMustDoTask()
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objTask In Application.ActiveExplorer.Selection
With objTask
objTask.Categories = "A - Must Do (Today)"
.Save
End With
Next
Set objTask = Nothing
End Sub
Sub CatorgorizeAsCouldDoTask()
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
For Each objTask In Application.ActiveExplorer.Selection
With objTask
objTask.Categories = "C - Could Do (10 Days or More)"
.Save
End With
Next
Set objTask = Nothing
End Sub