Saving all emails in a specific folder to the Hard Drive

[rrenis]

Hi - I've been using some code posted by spartacus132 to save individual emails to a specific folder on my hard drive. I later modified it after some searching on google to permentantly delete (using objCDO) the selected email from outlook's folder.

I now want to automate saving all of the emails in a specific folder and then delete them. I've got the code below as a mixture between spartacus132's and DRJ's KB entry... :bow:


Option Explicit

Sub FolderArchive()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrFolder As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String
Dim StrReceived As String
Dim StrSavePath As String
Dim SubFolder As Object
Dim FSO As Object
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim mItem As MailItem
Dim myMail As Outlook.MailItem
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objCDO As MAPI.Message
Dim objCDOSession As MAPI.Session
Dim strEntryID As String
Dim strStoreID As String
Set objApp = CreateObject("Outlook.Application")
Set objItem = objApp.ActiveExplorer.Selection.Item(1)
If Not objItem Is Nothing Then
Set objCDOSession = CreateObject("MAPI.Session")
objCDOSession.Logon "", "", False, False
strEntryID = objItem.EntryID
strStoreID = objItem.Parent.StoreID
Set objCDO = objCDOSession.GetMessage(strEntryID, strStoreID)
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
StrSavePath = "C:\Email Backup\Archive\"
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrSubject = mItem.Subject
StrWho = mItem.SenderName
StrName = StripIllegalChar(StrSubject)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrFile = StrSavePath & StrWho & " - " & StrName
StrFile = Left(StrFile, 213)
StrFile = StrFile & " (Received " & StrReceived & ") [" & Format(Now(), "HH.nn.ss") & "].msg"
mItem.SaveAs StrFile, 3
If Not objCDO Is Nothing Then
objCDO.Delete
End If
Next j
On Error GoTo 0
Next i
ExitSub:
objCDOSession.Logoff
Set objCDOSession = Nothing
Set objItem = Nothing
Set objCDO = Nothing
Set objApp = Nothing
Exit Sub
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 StrTime As String
Dim StrYear As String
Dim StrMonthDay 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, 11)
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
StrTime = Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 1)
StrDate = StrDay & "." & StrYear
StrDateTime = StrDate & "-" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, ".")
ExitFunction:
Set RegX = Nothing
End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub


At the moment when I run the macro it display's a list of all the folders in the mailbox which I then need to select the folder on which the macro is to run. As I only want to archive one specific folder does anyone know how to alter the code to so it automatically archives the "Inbox\Archive" subfolder without prompting? : pray2:

Also does anyone know if it's possible to delete all of the emails from the "Inbox\Archive" subfolder once they have been archived? :think:

Thanks for looking :hi:

Cheers,
rrenis :help

[Jacob Hilderbrand]

You can get the folder Entry ID.

ChosenFolder.EntryID

Then instead of iNameSpace.PickFolder use iNameSpace.GetFolderFromID.

To delete the emails, try this:


For i = 1 To ChosenFolder.Items.Count
ChosenFolder.Items.Remove 1
Next i

[rrenis]

Thanks DRJ - I'll give it a try later on today :yes

Just getting into VBA from dabbling in Excel so any advice is very much appreciated!

Thanks again for your time! :bow:

:beerchug:

Cheers,
rrenis

[rrenis]

Hi DRJ - sorry but I've just started to alter the code (the code to delete all items from the folder works great - thanks!) and when I've replaced iNameSpace.PickFolder with iNameSpace.GetFolderFromID


Set ChosenFolder = iNameSpace.GetFolderFromID

and then run the debugger I get a compile error - arguement not optional. To be honest I'm not too sure exactly what else I should be altering? Will the Sub GetFolder code no longer be required and if so should I be setting the EntryID as the "Indox\Archive" subfolder?? :doh:

cheers,
rrenis

[rrenis]

Sorry - Worked it out now! :omg2:

Thanks!
rrenis

[stevesumner]

I would also like to be able to do this. I see you worked it out rrenis, but what did you do? I am a total newbie, can you give me the code you used?

Also, I am using this code to save .msg to .txt. It works well, but I want to remove the header info. Any ideas how to do this?

Cheers

[Ben.Laxton]

To Anyone Who Can Help,

I too have been tinkering with this code :banghead: and though I have searched through all releated threads, I could not complete/replicate the code that rrenis described here. In particular, I want the code to do the following:


Allow me to choose subfolders as well as main folder (i.e. inbox, sent, etc.) in my email to save to my hard drive (as .msg files with attachments)
Automatically delete the emails I just saved to my hard drive (but not the folder or subfolder)If anyone has the updated code for this, I would be very grateful.

Thanks,

Ben

[ramserp]

Hi Friends,

I am also using this code, it copying all the folders under the root folder. How can we omit one or two from copying outlook to hard disk. I don't want copy drafts folder and it's sub folders.

I would greatful if anyone of you provide solution.

Thanks & Regards
Ramesh

[Ben.Laxton]

Dear Friends, :help

I tinkered some more with that code I just asked about (ramserp asked about this too). I have managed to make the code delete all the emails in the main folder (the only folder you can select without getting an error) and all subfolders once it has saved a copy to my chosen destination on the hard drive. This is something that I needed for my task, and I understand if no one else needs that, but I wanted to share it anyway [see code at end of post].

I still cannot figure out why I can't select sub folders. :banghead: When I run the code and select a subfolder, I get the error:

Run-time '76':
Path Not Found

When I choose debug, the code selects the error on the following line:

FSO.CreateFolder (StrFolderPath)

I read in another post (Charlize posted a reply on 05-29-2008 02:34 AM to the Thread: "Save Outlook Emails to Hard Drive" dated 12-07-2006 12:25 PM, started by g8r777) that a solution would be to use the code:

Dir

to check for a directory and the code:

MkDir

to create a directory instead of the FSO-method (from what I can tell, FSO is FileSystemObject).

Being a newbie to VBA, I am trying to make this work and I have NO idea :think: how to incorporate that into the existing code (does this replace FSO?). I tried deleting the FSO lines (note my comments next to those lines in the code) and the code runs AND it allows me to select sub folders AND it deletes my emails (like I programmed it to do). HOWEVER, I have NO idea where the emails go on my hard drive after that - they do not go to the folder I have specified.:dunno

That is as far as I have come thus far - if anyone could please help : pray2: me, I will be eternally grateful. I am continuing to tinker and if I find a solution I would be happy to share it with you all.

Drifting on the 'plains but still searching,

Ben

My new code (that deletes all emails in the main and sub folders):


Option Explicit

Sub SaveMainEmailFolderToHardDrive()

Dim i As Long
Dim j As Long
Dim n As Long
Dim z As Long 'New line of code
Dim iItem As Long 'New line added from other code
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String 'New line added from other code
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 iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As Folder 'Modifed code - was MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then 'Tried to Delete Code:
FSO.CreateFolder (StrFolderPath) 'Tried to Delete Code:
End If 'Tried to Delete Code:

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime) 'Modified Code: replaced mItem with .Item(j)
StrSubject = mItem.Subject 'Modified Code: replaced mItem with .Item(j)
StrWho = mItem.SenderName 'New Code
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3 'Modified Code: replaced mItem with .Item(j)
mItem.Delete 'New Code
Next j
End With 'New code added in conjunction with With code above in j
'Removed Code: On Error GoTo 0
'Former location of Next i code

'Copied code from above with "z" for reference - want access to subfolders only
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For z = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(z)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrWho = mItem.SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
mItem.Delete
Next z
'Removed Code: On Error GoTo 0
End With 'New code added in conjunction with With code above in n
Next i 'Code moved from above
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 = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

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

ExitFunction:

Set RegX = Nothing

End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.folderpath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


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

[Ben.Laxton]

Dear Friends,

With the gracious help of Jimmy Pena (visit his blog below)

codeforexcelandoutlook.com/blog

a solution to the code problem has been found! :clap: This code allows you to select either the main or sub folders and then select a folder on the hard drive to move the emails (and attachments) as a .msg file to. Currently this code also deletes the emails once they have been moved to the hard drive. If you do not want that capability, simply delete the line of code:


mItem.Delete

Without further ado, and with permission from JP (who will also be posting this on his website/blog), here is the code:

Cheers!

Ben


Sub SaveAllEmails_ProcessAllSubFolders_Delete6()

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String 'New line added from other code
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 iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
Call CreateSubDirectories(StrFolderPath) 'New code from JP
'FSO.CreateFolder (StrFolderPath) 'Original code
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = SubFolder.Items.Count To 1 Step -1 'New code from JP
'1 To SubFolder.Items.Count 'Original Code
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrWho = mItem.SenderName 'New Code
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256) 'Added additionally
mItem.SaveAs StrFile, 3
mItem.Delete 'New code from JP
Next j
On Error GoTo 0
Next i

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

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.folderpath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


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

'New code from JP below:
Function CreateSubDirectories(fullPath As String)
Dim str As String
Dim strarray As Variant
Dim i As Long
Dim basePath As String
Dim newPath As String
' add trailing slash
str = fullPath
If Right$(str, 1) <> "\" Then
str = str & "\"
End If
' split string into array
strarray = Split(str, "\")
basePath = strarray(0) & "\"
' loop through array and create progressively
' lower level folders
For i = 1 To UBound(strarray) - 1
If Len(newPath) = 0 Then
newPath = basePath & newPath & strarray(i) & "\"
Else
newPath = newPath & strarray(i) & "\"
End If
If Not FileOrDirExists(newPath) Then
MkDir newPath
End If
Next i
End Function
Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)

Dim iTemp As Integer

'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)

'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select

'Resume error checking
On Error GoTo 0
End Function

[richardfishb]

Sorry - Worked it out now! :omg2:

Thanks!
rrenis
I've managed to find out what rrenis worked out and didn't post.

Here is a link that explains where to get the EntryID to use in:

" Then instead of iNameSpace.PickFolder use iNameSpace.GetFolderFromID "

And where to get the EntryID from.

w.w.w.fabalou.com/Outlook/GetOutlookFolder.asp

My code now looks like:



Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.GetFolderFromID("000000001A447390AA6611CD9BC800AA002FC45A03003CEE60E6DBEA0B4DA265D483097E709 C00000009686A0000")

Where the long number is a reference to my public folder I found using the code in the link above. When you use the link above step through the code and open a locals window to view the values generated as you step through.

PM me if you get stuck.

[fourstar787]

loving this code! Works a treat!

though is there any way to only save those files that have particular flags against them? (ie red flags, blue flags etc!)

EDIT:

nevermind - i figured it out! added a neat little IF THEN routine to save ALL the emails but to only delete the ones that were flagged as complete :)

in addition i tweaked the save file name around to show our required file format

Hats off to the author of this code! saved me a **** load of manual renaming of files and sifting through the inbox!

[ktavui]

:help This code is similar to what I need, but does anyone know if there is a way to bypass the UI, and enable the macro to automatically save emails by keywords (or project numbers in my case) to their specified folders on the network drive? Any input would be appreciated.

Thanks,