I have a macro to do some task is that transfer the opened mailitem to specific folder in my hard drive.That code is like:
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
This code is belongs to save mail attachments:-
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
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
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "D:\macro\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
strFile = strFolderpath & strFile
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
Now i want to add specific name to when i right click on mailitem after selecting the name this code has to execute.for doing this what i need to do please help me to find a solution.