Macro to add Date & Time etc to "drag to save" e-mails

Status
Not open for further replies.

Liam

Member
Outlook version
Outlook 2019 64-bit
Email Account
IMAP
Hi all,

I'm wondering if anyone could help with this... I recently found a macro online that will save my e-mails to a folder and add the date, time, sender, recipient and subject to each email as it saves it. This in itself is really helpful but would really save extra time if it was possible to do this when also saving emails when we drag and drop them... would anyone have any ideas if that's possible and how to go about it?

Thanks in advance!

The macro I have at the minute is as follows:

Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.SenderName & " to " & oMail.ReceivedByName & " RE- " & " [ " & oMail.Subject & " ] "
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "dd.mm.yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hh'nn'ss'", _
vbUseSystemDayOfWeek, vbUseSystem) & "--" & sName & ".msg"

sPath = enviro & "\Documents\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG

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, ":", 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
 
No, its not possible to do it on a drag and drop - you would need to watch the windows folder for changes.

If you want to be able to choose a folder, you can use a "folder picker" to select there the message is saved.
How to use Windows filepaths in a macro (slipstick.com)
 
Ah ok, thanks for your help and fast response. It is a great macro btw it’s very helpful in my job!
 
Hi again,

Does anyone know is it possible to change the "SenderName" to display as initials in order of first name last name and the "ReceivedByName" seems to always display my name when saving even if I'm CC'd in e-mails that actually aren't directly to me would anyone have any ideas on this also so it displays who the e-mail was sent to and not me as a CC?

Many thanks, this macro has been a real time saver!
 
change the "SenderName" to display as initials in order of first name last name
you can change this using vba and Redemption - grabbing the initials might be more difficult - I have a sample macro that pulls the name from the contact.


the "ReceivedByName" seems to always display my name
I suppose you might be able to, but I don't have code. Because it is in your inbox, it was received by you.... so I'm not sure I understand why you'd need to do this.
 
Thanks Diane,

It's basically because I have to save e-mails of other colleagues in my organisation or team so the person the e-mail was actually sent to or sent by isn't always me if that makes sense, I was just CC'd in it.

So if John Doe sent an e-mail to Jane Doe with me CC'd and I Joe Bloggs save it it will save as "Doe, John to Bloggs, Joe" instead of Doe, John to Doe, Jane".

And thanks I'll have a look through that link, it would be brilliant if I could get it to save as "JD to JD"
(My colleagues give out to me for saving such long titled e-mails)
 
I should say as well that other people on my team review the e-mails we save so they find it confusing if it looks like they've all been sent to me.
 
If I have time, I'll see if it can be done using a macro. It will be a few days though - I have 3 projects I'm working on.
 
Thanks Diane,

It's basically because I have to save e-mails of other colleagues in my organisation or team so the person the e-mail was actually sent to or sent by isn't always me if that makes sense, I was just CC'd in it.

So if John Doe sent an e-mail to Jane Doe with me CC'd and I Joe Bloggs save it it will save as "Doe, John to Bloggs, Joe" instead of Doe, John to Doe, Jane".

And thanks I'll have a look through that link, it would be brilliant if I could get it to save as "JD to JD"
(My colleagues give out to me for saving such long titled e-mails)
I am having the same issue. Have you found a fix yet mate?
 
If I have time, I'll see if it can be done using a macro. It will be a few days though - I have 3 projects I'm working on.
Hi Diane, have you managed to find the code for the 'To' field? I'm assuming I need to replace the highlighted portion below!?!

sName = oMail.SenderName & " to " & oMail.ReceivedByName & " [ " & oMail.Subject & " ] "
ReplaceCharsForFileName sName, "-"
 
No, its not possible to do it on a drag and drop - you would need to watch the windows folder for changes.

If you want to be able to choose a folder, you can use a "folder picker" to select there the message is saved.
How to use Windows filepaths in a macro (slipstick.com)
Hi Diane,
I used you browse for folder function, a browse for folder window now pops up, but nothing happens when I choose a folder?

Here is the whole code I have now.

Any help would be great.

regards, Martijn



Option Explicit
Public Sub SaveMessageWithDate()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject & ""
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hh.nn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = BrowseForFolder
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG

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, ":", 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

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:
BrowseForFolder = False
End Function
 
I found this code, seems nice, but only works for one e-mail at a time a get the dialog window for each email. not very handy when saving 70 e-mails. how would you solve this?

Function BrowseForFolder(Optional sFolder As String) As String
Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
On Error Resume Next
Set exApp = GetObject(, "Excel.Application")
On Error GoTo 0
If exApp Is Nothing Then
Set exApp = CreateObject("Excel.Application")
End If
Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.InitialFileName = sFolder
.AllowMultiSelect = False
If .Show <> -1 Then GoTo lbl_Exit
strPath = .SelectedItems(1) & Chr(92)
End With
lbl_Exit:
BrowseForFolder = strPath
exApp.Quit
Set exApp = Nothing
Exit Function
End Function
 
I found this code, seems nice, but only works for one e-mail at a time a get the dialog window for each email. not very handy when saving 70 e-mails. how would you solve this?

Function BrowseForFolder(Optional sFolder As String) As String
Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
On Error Resume Next
Set exApp = GetObject(, "Excel.Application")
On Error GoTo 0
If exApp Is Nothing Then
Set exApp = CreateObject("Excel.Application")
End If
Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.InitialFileName = sFolder
.AllowMultiSelect = False
If .Show <> -1 Then GoTo lbl_Exit
strPath = .SelectedItems(1) & Chr(92)
End With
lbl_Exit:
BrowseForFolder = strPath
exApp.Quit
Set exApp = Nothing
Exit Function
End Function
"Excel.Application" can also be "Word.Application"
 
You want to select the folder and have that used for all selected messages (or all in the folder)? you need to select the folder before you loop the messages. I thought one of my samples did that...

See if this works -

Code:
Public Sub SaveMessageWithDate()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String

sPath = BrowseForFolder

For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject & ""
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hh.nn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG

End If
Next

End Sub
 
thank you it works.... it seems that sPath = BrowseForFolder just needed to be moved up in the code.

what I now have is:

Option Explicit
Public Sub SaveMessageWithDate()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

sPath = BrowseForFolder

enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hh.nn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG

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, ":", 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

Function BrowseForFolder(Optional sFolder As String) As String
Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
On Error Resume Next
Set exApp = GetObject(, "Word.Application")
On Error GoTo 0
If exApp Is Nothing Then
Set exApp = CreateObject("Word.Application")
End If
Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.InitialFileName = sFolder
.AllowMultiSelect = False
If .Show <> -1 Then GoTo lbl_Exit
strPath = .SelectedItems(1) & Chr(92)
End With
lbl_Exit:
BrowseForFolder = strPath
exApp.Quit
Set exApp = Nothing
Exit Function
End Function
 
thank you it works.... it seems that sPath = BrowseForFolder just needed to be moved up in the code.

what I now have is:

Option Explicit
Public Sub SaveMessageWithDate()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

sPath = BrowseForFolder

enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hh.nn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG

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, ":", 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

Function BrowseForFolder(Optional sFolder As String) As String
Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
On Error Resume Next
Set exApp = GetObject(, "Word.Application")
On Error GoTo 0
If exApp Is Nothing Then
Set exApp = CreateObject("Word.Application")
End If
Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.InitialFileName = sFolder
.AllowMultiSelect = False
If .Show <> -1 Then GoTo lbl_Exit
strPath = .SelectedItems(1) & Chr(92)
End With
lbl_Exit:
BrowseForFolder = strPath
exApp.Quit
Set exApp = Nothing
Exit Function
End Function
This is great. Thanks for this, very very helpful.

Just wondering - is it possible to include a line within the code, that the Save to Box, directs the user to a certain Drive/Location by default?
At the moment, it is initially directing to the System Folder.

Thanks for any help on this would be sincerely appreciated,

Thanks all,

Best,
 
add the starting file path -
sPath = BrowseForFolder("C:\Users\username\documents\")

Use the highest path necessary since you can browser up, only down. In the example path, all folders in documents would be available, but nothing in C:\users or above.
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
M Macro to add date/time stamp to subject Outlook VBA and Custom Forms 4
A Email Macro to add Date and Classification Outlook VBA and Custom Forms 2
C Macro to add multiple recipients to message Outlook VBA and Custom Forms 3
S Example VBA Macro - To Conditionally Change the From Account and Add a BCC Address on Emails Outlook VBA and Custom Forms 11
Tanja Östrand Outlook 2016 - Create Macro button to add text in Subject Outlook VBA and Custom Forms 1
snhnic Macro that does not overwrite but add a number Outlook VBA and Custom Forms 1
W Macro to add a word in Subject Line Using Outlook 1
L Macro to Add Catgegory to List of Contacts Using Outlook 4
L Outlook 2007 Macro to Add Text to a Contact Field Using Outlook 10
W Add to Calendar links - auto accept with macro Using Outlook 1
B Auto BCC VBA macro: how to add exceptions? Using Outlook 28
M How to Create Macro in Visual Basic to add Contacts from Personal Folder Using Outlook 4
E Macro to add text to a Message Outlook VBA and Custom Forms 3
P How do I create a macro to add contacts from email messages? Outlook VBA and Custom Forms 1
D Call add-in method from macro? Outlook VBA and Custom Forms 1
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
X Run macro automatically when a mail appears in the sent folder Using Outlook 5
mrrobski68 Issue with Find messages in a conversation macro Outlook VBA and Custom Forms 1
G Creating Macro to scrape emails from calendar invite body Outlook VBA and Custom Forms 6
M Use Macro to change account settings Outlook VBA and Custom Forms 0
J Macro to Reply to Emails w/ Template Outlook VBA and Custom Forms 3
C Outlook - Macro to block senders domain - Macro Fix Outlook VBA and Custom Forms 2
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
S macro error 4605 Outlook VBA and Custom Forms 0
A Macro Mail Alert Using Outlook 4
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro GoTo user defined search folder Outlook VBA and Custom Forms 6
D Outlook 2016 Creating an outlook Macro to select and approve Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to check Cursor & Focus position Outlook VBA and Custom Forms 8
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
M Outlook 2019 Macro not working Outlook VBA and Custom Forms 0
S Outlook 365 Help me create a Macro to make some received emails into tasks? Outlook VBA and Custom Forms 1
Geldner Send / Receive a particular group via macro or single keypress Using Outlook 1
D Auto Remove [EXTERNAL] from subject - Issue with Macro Using Outlook 21
V Macro to count flagged messages? Using Outlook 2
sophievldn Looking for a macro that moves completed items from subfolders to other subfolder Outlook VBA and Custom Forms 7
S Outlook Macro for [Date][Subject] Using Outlook 1
E Outlook - Macro - send list of Tasks which are not finished Outlook VBA and Custom Forms 3
E Macro to block senders domain Outlook VBA and Custom Forms 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to answer a mail with attachments Outlook VBA and Custom Forms 2
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
J Macro to Insert a Calendar Outlook VBA and Custom Forms 8
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6

Similar threads

Back
Top