#1
|
|||
|
|||
Saving emails with a specific name
Hi all,
I was hoping someone here could help me find a solution to a problem. Due to a work requirement I have to log and save every single email sent and received in a specific format which can be a real pain. Is there a way to save emails with a custom rule, that would save emails by the date, time, recipient and then possibly subject? At the moment I'm manually saving them all like this..... "18-03-14 - 10.11 -fr Mr A - Website Question". Thank you, J |
#2
|
||||
|
||||
I have covered this several times before, however it bears repetition. You need something like the following which will save a selected message in the named folder, or you can run SaveItem as a script from a rule to process the messages as they arrive or in conjunction with a send event macro to process them as they are sent. You can save as messagfe format or text - the codes for both are shown.
Change Const strPath As String = "C:\Path\Outlook Message Backup\" to reflect where you want to save the messages (the path will be created if it doesn't exist). And change If olItem.sender Like "*@gmayor.com" Then to reflect your domain used for sending the messages Code:
Option Explicit Sub SaveMessage() 'An Outlook macro by Graham Mayor - www.gmayor.com 'Saves the currently selected message Dim olMsg As MailItem Dim sPath As String On Error Resume Next Set olMsg = ActiveExplorer.Selection.Item(1) SaveItem olMsg lbl_Exit: Set olMsg = Nothing Exit Sub End Sub Private Sub SaveItem(olItem As MailItem) 'Graham Mayor - http://www.gmayor.com - Last updated - 14 Mar 2018 'The main macro called by the above macros. 'This macro can be used as a script to save the messages as they arrive '18-03-14 - 10.11 -fr Mr A - Website Question" Dim fname As String Const strPath As String = "C:\Path\Outlook Message Backup\" CreateFolders strPath If olItem.sender Like "*@gmayor.com" Then 'Your domain fname = Format(olItem.SentOn, "yy-mm-dd") & " - " & _ Format(olItem.SentOn, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject Else fname = Format(olItem.ReceivedTime, "yy-mm-dd") & " - " & _ Format(olItem.ReceivedTime, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject End If fname = Replace(fname, Chr(58) & Chr(41), "") fname = Replace(fname, Chr(58) & Chr(40), "") fname = Replace(fname, Chr(34), "-") fname = Replace(fname, Chr(42), "-") fname = Replace(fname, Chr(47), "-") fname = Replace(fname, Chr(58), "-") fname = Replace(fname, Chr(60), "-") fname = Replace(fname, Chr(62), "-") fname = Replace(fname, Chr(63), "-") fname = Replace(fname, Chr(92), "-") fname = Replace(fname, Chr(124), "-") On Error GoTo err_Handler SaveUnique olItem, strPath, fname lbl_Exit: Exit Sub err_Handler: WriteToLog strPath & "Error Log.txt", strPath & fname Err.Clear GoTo lbl_Exit End Sub Private Function CreateFolders(strPath As String) 'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017 'Creates the full path 'strPath' if missing or incomplete Dim strTempPath As String Dim lngPath As Long Dim vPath As Variant Dim oFSO As Object Dim i As Integer Set oFSO = CreateObject("Scripting.FileSystemObject") vPath = Split(strPath, "\") If Left(strPath, 2) = "\\" Then strPath = "\\" & vPath(2) & "\" For lngPath = 3 To UBound(vPath) strPath = strPath & vPath(lngPath) & "\" If Not oFSO.FolderExists(strPath) Then MkDir strPath Next lngPath Else strPath = vPath(0) & "\" For lngPath = 1 To UBound(vPath) strPath = strPath & vPath(lngPath) & "\" If Not oFSO.FolderExists(strPath) Then MkDir strPath Next lngPath End If lbl_Exit: Set oFSO = Nothing Exit Function End Function Private Function SaveUnique(oItem As Object, _ strPath As String, _ strFileName As String) 'An Outlook macro by Graham Mayor - www.gmayor.com 'Ensures that filenames are not overwritten Dim lngF As Long Dim lngName As Long Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") lngF = 1 lngName = Len(strFileName) Do While fso.FileExists(strPath & strFileName & ".msg") = True strFileName = Left(strFileName, lngName) & "(" & lngF & ")" lngF = lngF + 1 Loop 'oItem.SaveAs strPath & strFileName & ".txt", olTXT oItem.SaveAs strPath & strFileName & ".msg", olMsg lbl_Exit: Exit Function End Function Sub WriteToLog(strPath As String, strValue As String) Dim fso As Object Dim ff As Long Set fso = CreateObject("Scripting.FileSystemObject") ff = FreeFile If fso.FileExists(strPath) Then Open strPath For Append As #ff Else Open strPath For Output As #ff End If Print #ff, strValue Close #ff lbl_Exit: Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Thank you. I'll give it a go.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Not process the saving invoice & never go to the next unless complete specific cell | DIMI | Excel Programming | 6 | 08-21-2017 07:08 AM |
Saving new word documents to specific files | maxbeedie | Word | 1 | 11-15-2016 04:04 AM |
Saving sent mails to specific folder | kammil121 | Outlook | 0 | 10-22-2014 02:26 AM |
Saving Emails to New Folder along with Attachments | thundercats9595 | Outlook | 2 | 02-01-2014 12:32 PM |
Saving files in a specific path | bjtrain83 | Word | 1 | 01-10-2010 02:36 PM |