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

[Liam]

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

 

[Diane Poremsky]

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)

 

[Liam]

Ah ok, thanks for your help and fast response. It is a great macro btw it’s very helpful in my job!

 

[Liam]

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!

 

[Diane Poremsky]

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.

How to change the From field on incoming messages

How to use Redemption to change the sender's name field on messages.

www.slipstick.com

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.

 

[Liam]

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)

 

[Liam]

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.

 

[Diane Poremsky]

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.

 

[Liam]

Thanks Diane I appreciate that

 

[DASHAAA13]

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?

 

[DASHAAA13]

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

 

[Mbraakman]

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

 

[Mbraakman]

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

 

[Mbraakman]

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"

 

[Diane Poremsky]

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 -

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

 

[Mbraakman]

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

 

[PatrickJ]

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,

 

[Diane Poremsky]

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.