Move outlook emails >90 days to shared drive (Desktop) Folder

[Hemant Sonawane]

Hi Diane

I am new to VBA macros, Please help me.
I found macro on this forum that moves the mails which are > 7 days within the oulook folder named as OLD. Can this macro amended to the level where macro can move emails > 90 days to Shared Drive (desktop) folder.
Below is the Macro for your reference

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)
 
  ' use your datafile name and each folder in the path
  Set objDestFolder = objNamespace.Folders("xyz@domain.com"). _
  Folders("Inbox").Folders("Old")
 
  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 90 days, adjust as needed.
  If intDateDiff > 45 Then
  objVariant.Move objDestFolder
  'count the # of items moved
  lngMovedItems = lngMovedItems + 1
 
  End If
  End If
  Next
 
  ' Display the number of items that were moved.
 
  MsgBox "Moved " & lngMovedItems & " messages(s)."
  Set objDestFolder = Nothing
  End Sub

 

[Forum Admin]

Yes; Yes. The 90 days part is easy

If intDateDiff > 90 Then

Merge it with the macro at http://www.slipstick.com/developer/code-samples/save-selected-message-file/ to handle the save to file system part.

short version is replace
objVariant.Move objDestFolder

with
objVariant.SaveAs sPath & sName, olMSG
you'll need the code from that macro to build the file name - path will be entered in this format: \\shared\folder\path

 

[Hemant Sonawane]

Hi
Can you please do change the macro i will upadate the pathpath . i dnt knw how to change or the macro coding

Thanks

 

[Diane Poremsky]

This should do it.
See http://www.slipstick.com/developer/how-to-use-outlooks-vba-editor/ if you need help using the VBA editor.

Sub SaveAgedMail()

Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))

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 90 days, adjust as needed.
If intDateDiff > 45 Then


sName = objVariant.subject
ReplaceCharsForFileName sName, "_"
dtDate = objVariant.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
    
sPath = enviro & "\Documents\"


objVariant.SaveAs sPath & sName, olMSG

End If
End If
Next

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

 

[Hemant Sonawane]

Hi Diane
I am new to macro. can you please let me know where can i put may email id in above macro. like it was given in first macro
[
' use your datafile name and each folder in the path
Set objDestFolder = objNamespace.Folders("xyz@domain.com"). _
Folders("Inbox").Folders("Old")
]
Thanks
-----------------

 

[Diane Poremsky]

You want to move emails > 90 days to Shared Drive (desktop) folder. The code with the username moves them to a different pst file in your profile.

This line gets the messages that are in the inbox:
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

and this line saves them in the my documents folder on the computer:
sPath = enviro & "\Documents\"

If the shared folder is under your user account (C:\users\me), change documents to the folder path, otherwise use
sPath ="C:\the\folder\path\"

If you want to delete them after you save them, use
objVariant.delete after the saveas.