Addding right click option to selected mailitem in VBE app.

Question

By default whenever we right click on mailitem we can see options like copy.junk,delete,reply,replyall in the same way i want to add a option and whenever user clicks on that option that mail is exported to specific folder in hard disk.

           Here i have the code to export the mailitem to specific folder its working fine when i click button.But now i want to execute the same code select a option by right clicking the mailitem.

 

 

The macro code:

 

Public Sub export1()

Const OLTXT = 0

Dim currentExplorer As Explorer

Dim Selection As Selection

Dim oMail As Outlook.MailItem

Dim obj As Object

Dim sPath As String

Dim dtDate As Date

Dim sName As String

Set currentExplorer = Application.ActiveExplorer

Set Selection = currentExplorer.Selection

For Each obj In Selection

Set oMail = obj

sName = oMail.Subject

ReplaceCharsForFileName sName, "_"

dtDate = oMail.ReceivedTime

sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _

vbUseSystem) & Format(dtDate, "-hhnnss", _

vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".html"

oMail.SaveAs "D:\macro\" & sName, OLTXT

Next

Module2.SaveAttachments

End Sub

 

 

 

Private Sub ReplaceCharsForFileName(sName As String, _

sChr As String _

)

sName = Replace(sName, "/", sChr)

sName = Replace(sName, "\", sChr)

sName = Replace(sName, ":", sChr)

sName = Replace(sName, "?", sChr)

sName = Replace(sName, Chr(34), sChr)

sName = Replace(sName, "<", sChr)

sName = Replace(sName, ">", sChr)

sName = Replace(sName, "|", sChr)

End Sub

 Modue2.SaveAttachments code is :

 

 

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 = CreateObject("Outlook.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 = "D:\macro\"

' 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

MsgBox "saved in D:\macro with attachments"

Else

MsgBox "mail is saved and no attachments for this selection mail"

End If

Next

ExitSub:

Set objAttachments = Nothing

Set objMsg = Nothing

Set objSelection = Nothing

Set objOL = Nothing

End Sub