Manage Outlook Emails:
'Set objDestFolder = objSourceFolder.Folders(sSenderName)
'
'If objDestFolder Is Nothing Then
' Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
'End If
'File selected messages by sender's name
'While i 'm not a big fan of filing messages in hundreds of folders, I can see the value in filing some messages. This version of the macros works on the selected message(s) and creates a subfolder in the current folder.
Public Sub MoveSelectedMessages()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 4 Then
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
' Dim objInbox As Outlook.MAPIFolder
' Set objInbox = objNamespace.Folders("alias@domain.com"). _
Folders("Inbox") ' or whereever the folder is
' Set objDestFolder = objInbox.Folders(sSenderName)
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Err.Clear
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
'File aged messages by sender's name
'This version of the macro moves messages to an Inbox subfolder named for the sender. It looks for the display name, and if a folder does not exist, it creates it. If the sender uses different email clients, the messages may be filed in several folders. Using the sender's email address would eliminate this problem, but make it harder to know who each folder is for.
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 40 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
Sub MoveAllMails()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > -1 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
'File by Year
'This code snippet shows how to file messages by year, moving only those messages that are older than a year.
'Dim intYear As String
'
' If objVariant.Class = olMail Then
' intDateDiff = DateDiff("d", objVariant.ReceivedTime, Date)
' Debug.Print Date & " " & intDateDiff
'
' If intDateDiff > 365 Then
' intYear = Year(objVariant.ReceivedTime)
' Debug.Print objVariant.Subject & "--" & intYear
'
' On Error Resume Next
'
' Set objDestFolder = objSourceFolder.Folders(intYear)
'' Debug.Print objDestFolder
' If objDestFolder Is Nothing Then
' Set objDestFolder = objSourceFolder.Folders.Add(intYear)
' End If
' objVariant.Move objDestFolder
' 'count the # of items moved
' lngMovedItems = lngMovedItems + 1
' Set objDestFolder = Nothing
'
' End If
' Err.Clear
' End If
' Next
'
'How to use macros
'
'First: You will need macro security set to low during testing.
'
'To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
'
'After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
'
'Open the VBA Editor by pressing Alt+F11 on your keyboard.
'
'To put the code in a module:
'
'Stellar Phoenix Outlook PST Repair
'Repair and restore data from damaged or corrupted Microsoft outlook file
'Right click on Project1 and choose Insert > Module
'Copy and paste the macro into the new module.
'SOURCE - http://www.slipstick.com/developer/file-messages-senders-name/
The following two macros will move the messages to a folder named for the sender, creating the folder if it does not exist. The first macro works on selected messages in any folder, moving the messages to subfolders under the current folder. The second macro is the one Joel tweaked and needed help with the code to create the folder.
Creating a new folder is just a couple of lines. By using On Error Resume Next, you can set the folder variable and next line runs if an error is encountered. This is important because an error will be triggered when you try to set the destination folder to a folder that doesn't exist. The next lines tell Outlook to create the folder if it doesn't exist.
'On Error Resume Next'Set objDestFolder = objSourceFolder.Folders(sSenderName)
'
'If objDestFolder Is Nothing Then
' Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
'End If
'File selected messages by sender's name
'While i 'm not a big fan of filing messages in hundreds of folders, I can see the value in filing some messages. This version of the macros works on the selected message(s) and creates a subfolder in the current folder.
Public Sub MoveSelectedMessages()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 4 Then
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
' Dim objInbox As Outlook.MAPIFolder
' Set objInbox = objNamespace.Folders("alias@domain.com"). _
Folders("Inbox") ' or whereever the folder is
' Set objDestFolder = objInbox.Folders(sSenderName)
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Err.Clear
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
'File aged messages by sender's name
'This version of the macro moves messages to an Inbox subfolder named for the sender. It looks for the display name, and if a folder does not exist, it creates it. If the sender uses different email clients, the messages may be filed in several folders. Using the sender's email address would eliminate this problem, but make it harder to know who each folder is for.
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 40 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
Sub MoveAllMails()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > -1 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
'File by Year
'This code snippet shows how to file messages by year, moving only those messages that are older than a year.
'Dim intYear As String
'
' If objVariant.Class = olMail Then
' intDateDiff = DateDiff("d", objVariant.ReceivedTime, Date)
' Debug.Print Date & " " & intDateDiff
'
' If intDateDiff > 365 Then
' intYear = Year(objVariant.ReceivedTime)
' Debug.Print objVariant.Subject & "--" & intYear
'
' On Error Resume Next
'
' Set objDestFolder = objSourceFolder.Folders(intYear)
'' Debug.Print objDestFolder
' If objDestFolder Is Nothing Then
' Set objDestFolder = objSourceFolder.Folders.Add(intYear)
' End If
' objVariant.Move objDestFolder
' 'count the # of items moved
' lngMovedItems = lngMovedItems + 1
' Set objDestFolder = Nothing
'
' End If
' Err.Clear
' End If
' Next
'
'How to use macros
'
'First: You will need macro security set to low during testing.
'
'To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
'
'After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
'
'Open the VBA Editor by pressing Alt+F11 on your keyboard.
'
'To put the code in a module:
'
'Stellar Phoenix Outlook PST Repair
'Repair and restore data from damaged or corrupted Microsoft outlook file
'Right click on Project1 and choose Insert > Module
'Copy and paste the macro into the new module.
'SOURCE - http://www.slipstick.com/developer/file-messages-senders-name/
No comments:
Post a Comment