Using VBA to copy an email to a folder and then delete it

[rrenis]

Hi - I've never used VBA in Outlook before but was wondering if the following is possible (or am I wasting my time looking into it!) :read2:

I'd like to have something in place which would improve my filing - I was hoping to have some code that would allow me to select a folder on the hard drive to save the email to and then delete it from outlook (if deleting the email could be made optional then all the better).

Making things even more complicated we use 4 figure references in the subject line which are project specific - could VBA be used to lookup the directories on the hard drive and find the correct directory to save it to? :bug:

This last request is probably taking things too far but does anyone know if this could be done, or better still suggest some code to point me in the right direction? Failing this does anyone know if any 'add-ons' are availbe that could do this? :sleuth:

Thanks for taking the time to read this.

Cheers,
rrenis

[spartacus132]

How to use:

Open Outlook
Open the VBE (Alt + F11)
From the VBE top menu: Insert | Module
Paste all of the code in the module that was created
Close the VBE
From the Outlook top menu: Tools | Macro | Macros...
Select SaveSelectedEmails and click Run

Option Explicit
Sub SaveSelectedEmails()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim mItem As MailItem
Dim FSO As Object

StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If


On Error Resume Next
With Outlook.ActiveExplorer.Selection
For iItem = 1 To .Count
StrReceived = ArrangedDate(.item(iItem).ReceivedTime)
StrSubject = .item(iItem).Subject
StrWho = .item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrWho & " - " & StrReceived & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.item(iItem).SaveAs StrFile, 3
.item(iItem).Delete

Next
End With

ExitSub:

End Sub

Function StripIllegalChar(StrInput)

Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:

Set RegX = Nothing

End Function


Function ArrangedDate(StrDateInput)

Dim StrFullDate As String
Dim StrFullTime As String
Dim StrAMPM As String
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If

StrFullDate = Left(StrDateInput, 10)

If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If

StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")

If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If

StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrMonth & "-" & StrDay & "-" & StrYear
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")

ExitFunction:

Set RegX = Nothing

End Function

Function BrowseForFolder(Optional OpenAt As String) As String

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

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

ExitFunction:

Set ShellApp = Nothing

End Function


The above code is based on a KB entry (http://vbaexpress.com/kb/getarticle.php?kb_id=875); I tailored it to suit your needs. It allows you to choose the folder, where you want to save the selected emails.

[rrenis]

:bug: Whoa! Thanks spartacus132!! :bug:

I'll give this a go later on today. Thanks so much for taking the time to compile some code. Your time is very much appreciated!! :bow:
:beerchug:
Cheers,
rrenis

[rrenis]

Hi spartacus132 - just tried it and its fantastic - many thanks for your help!! :cloud9:

Btw, do you know if the following can be acheived? Would it be possible to start the browse for folder in a selected directory, say C:\My Jobs. I presume it would be specified in the Function BrowseForFolder code :dunno (guessing).

Also - is there a way of 'attaching' the code to the close button so that once you've opened and read the email it prompts you where to save it when you close the window down.

Cheers,
rrenis

[spartacus132]

Replace your existing code with the one below and modify "StrSavePath" to point to the location where your would like to save by default. Regarding 'attaching' the code, i'll have to look into that, i am not that familiar with outlook...

Option Explicit
Sub SaveSelectedEmails()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Title As String
Dim mItem As MailItem
If MsgBox("Would you like to save to your preset location?", vbYesNo, "Save Location") = vbYes Then

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Please modify the default save location to suit your needs
StrSavePath = "C:\My Jobs\"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Else

StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
End If

If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If


On Error Resume Next
With Outlook.ActiveExplorer.Selection
For iItem = 1 To .Count
StrReceived = ArrangedDate(.item(iItem).ReceivedTime)
StrSubject = .item(iItem).Subject
StrWho = .item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrWho & " - " & StrReceived & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.item(iItem).SaveAs StrFile, 3

Next
End With

ExitSub:

End Sub

Function StripIllegalChar(StrInput)

Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:

Set RegX = Nothing

End Function


Function ArrangedDate(StrDateInput)

Dim StrFullDate As String
Dim StrFullTime As String
Dim StrAMPM As String
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If

StrFullDate = Left(StrDateInput, 10)

If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If

StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")

If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If

StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrMonth & "-" & StrDay & "-" & StrYear
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")

ExitFunction:

Set RegX = Nothing

End Function

Function BrowseForFolder(Optional OpenAt As String) As String

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

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

ExitFunction:

Set ShellApp = Nothing

End Function

[rrenis]

Hi spartacus132 - many thanks for your reply :bow:

I really appreciate your help. :thumb

Cheers,
rrenis

[spartacus132]

you are welcome!

[rrenis]

Hi spartacus132 :hi: Do you know a way that the code could altered to start the browse for folder in the C:\My Jobs folder rather than save it there automatically if I select 'Yes' so that a sub folder could be selected from the C:\My Jobs folder? I had a mess with it last night but nothing I tried worked :whyme:

Cheers,
rrenis

[mdmackillop]

Hi rrenis
Check in the KB. Search for items by Ken Puls :bow: (our newest MVP) who has a couple of relevant examples.

[rrenis]

Hi mdmackillop - thanks for the tip - I'll check Ken Puls's post out :yes

Cheers,
rrenis

[spartacus132]

In the function BrowseForFolder locate the line that says:

BrowseForFolder(0, "Please choose a folder", 0, OpenAt)


Replace "OpenAt" with the path you would like to browse to, by default.

For example:
BrowseForFolder(0, "Please choose a folder", 0, "C:\Documents and Settings\spartacus132\My Documents\")


I am fairly new to VBA, my suggestions may not be best practices, but it will get your request fulfilled...

[rrenis]

Hi spartacus132 :hi: Thanks again for your help - I really appreciate it :yes
:beerchug:
Cheers,
rrenis

[spartacus132]

rrenis, you are welcome!

[rrenis]

Hi - I've been using the code which spartacus132 very kindly posted for a couple of weeks now and it's been working great :bow:

I've tried to amend it slightly to give me the option of saving to a difference location if I press cancel when prompted to save in my 'C:\Backup Emails\' folder. Unfortunately with my limited VBA knowledge it's not working as I'd expect and I'm not sure what I'm doing wrong :doh:

Here's the code...

Function BrowseForFolder(Optional OpenAt As String) As String

Dim ShellApp As Object

Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Select a Folder below to save this email to", 0, "C:\Backup Emails\")
If BrowseForFolder = "" Then
If MsgBox("Save the email to another Folder?", vbYesNo, "Location") = vbYes Then
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Select a Folder below to save this email to", 0, OpenAt)
Else: GoTo ExitFunction
End If
Else
End If
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

ExitFunction:

Set ShellApp = Nothing

End Function


Can anyone spot anything obvious that I've done wrong and point me in the right direction please? :o:

Cheers,
rrenis

[rrenis]

btw does anyone know why the ArrangeDate Function sometimes works perfectly and other time it's returns something in no way resembling a date - maybe it's a quirk of Outlook 2003? :dunno