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