Solved

VBA Outlook archiv Folders and Emails

Posted on 2012-04-06
15
893 Views
Last Modified: 2013-02-16
Hello Everybody

I need a vba script that is able to move emails to an "Archiv" Mailbox.
The Script should be able to ask and check the date of each email.
and should only move those mails who are older than this date.

Also importat: it should be able to create the same folder structure on the target Mailbox "Archiv".

thanks
0
Comment
Question by:HelpdeskJBC
  • 9
  • 6
15 Comments
 
LVL 41

Expert Comment

by:dlmille
ID: 37818285
This app prompts you for a mail item received date such that all mail items on or before that date will be moved.  You are then prompted for a source, then destination folder (which must initially exist).  The source folder structure is replicated to the destination folder, if needed.  Then, each mail item in the source folder is evaluated against the prompted received date and then moved to the appropriate destination (re: Archive) folder.

Here's the code:
Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            If mItem.ReceivedTime <= recDate Then
                mItem.Move subDestFolder
            End If
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete!"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window


You must paste this in a public module in your Outlook VBA editor (hit Alt-F11 and insert a public module).  You can then run the macro called: ArchiveEmails_ProcessAllSubFolders()

Please advise any questions.

Cheers,

Dave
0
 

Author Comment

by:HelpdeskJBC
ID: 37826357
Hello dave,

thanks for the great work!

Unfortunately there is a Problem with "delivered" notifications and maybe with calender entrys etc are these different objects?

This line (60) makes an error:
Set mItem = subFolder.Items(j)
Runtime Error 13
Type mismatch

print subFolder.Items(j)
Delivered: test
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37828528
>> Unfortunately there is a Problem with "delivered" notifications and maybe with calender entrys etc are these different objects?

They are but they still exist as SubFolder.Items (obviously!)  We just need to change the datatype for mItem to Object as opposed to MailItem and then anything in the folder should move over.  I tested with a calendar and contact item and worked for me.

Here's the revised code:
Option Explicit

Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            If mItem.ReceivedTime <= recDate Then
                mItem.Move subDestFolder
            End If
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete!"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window


Dave
0
 

Author Comment

by:HelpdeskJBC
ID: 37841581
Hy dave!

I still get this error on the Delivered Items:

Run time Error 438
Object doesn't support this property or method

seems like this ist not supportet: print mItem.ReceivedTime
but can you handle it with the mItem.CreationTime ? for example only on error?

thanks for the help
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37841583
Can do an error trap.  But first, What line are you getting that error on?
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37841617
I see - line 62 - did you take a coffee break?  We can do this much more quickly if you respond - I'm up at 2:10am, so if you want to knock this out, let me know.

:)

Dave
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37841717
This code checks both ReceivedTime as well as CreationTime.  If either one does not create an error, it moves it, otherwise it advises you then continues on.

Please advise.  Its possible you have a corrupt record in the excel folder/database.  See if you can export that record, then delete it in your outlook folder, then reimport it.  Not sure that would fix things, but would be interesting to find out.  I don't have these problems of course, as I'm working with test data at this point, so its hard to reproduce a malformed record if that is what it is.  If its a Delivered Item as you say, then corruption may be the case.  Let's see what percentage of records fail.  You should be prompted with the error rate, and your immediate window will summarize all the subjects that failed, if they are not corrupt and actually print!

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'MailItem 'Early Binding
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = mItem.ReceivedTime
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 

Author Comment

by:HelpdeskJBC
ID: 37848616
The Program is now running without any errors, looks good, but I have problems with the destination folder. The Mails come to the wrong place.

I start the makro and mark the source folder (my inbox) and then i mark the destination folder (new data file empty mailbox)

i stoped the makro on line 78 and then i checked the folder names:
as you see this is a different folder

print subFolder
alt

print subdestfolder
SB

I noticed:
the folder list from my inbox is copied to the "archiv" mailbox without any problems
the program starts to copy from the first folder, but the destination folder is the last one on the "archiv" mailbox
the copy from the second folder comes to the destionation secont to last folder and so on...

should we change the line 78
mItem.move subDestFolder
to
mItem.move subFolder
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37849641
No - because the subFolder is where we're moving from. subDestFolder is keyed at the same time subFolder is keyed, so that should be correct.  subFolder is copied one folder down from the selected destination, which is why the index is offset by one on the line assigning subDestFolder.  There should be no confusion here.

I tested the code, so at least with my test data everything's falling to the same place.

Assuming you MAY be having corruption problems (or there's something else going on that we haven't considered) PLEASE just create two folders with some subfolders and put mail items in them.  Then, archive that.  Let me know if this simple test archives correctly.  

To be real clear, create a new pst, then move some data to it in different folders, create an Archive folder, then test against this.  This should be about as clean a test environment we can do, I believe.

If existing source folders don't (and we don't have a bug) archive correctly, but your tests do, then it could also be a sign of a corrupted .PST or Inbox, etc.

To demonstrate the code is currently correct ->

HMMM- let's try this enhancement to the code - if the subfolder of the source and destination are not the same, you should get a popup notification (see line 63-65):

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        If subFolder.Name <> subDestFolder.Name Then
            MsgBox "This should not be! -> " & subFolder.Name & "," & subDestFolder.Name
        End If
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = mItem.ReceivedTime
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window


Dave
0
 

Author Comment

by:HelpdeskJBC
ID: 37851259
hey

so i see the problem is this:
When the destination is a new pst (mailbox) im running in that error
but if I use the same pst box as source and destination then everything is fine.

Just one more thing i had to change line 12
Dim mItem As MailItem to dim as Object, because the programm is running in a failure on line 68 "Set mItem = subFolder.Items(j)"
Runtime error 13 Type Missmatch
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37852318
Right.  I'll change my version to object as well


Will try on different PSTs and see if I can replicate the problem.  I think we just might be there with this discovery

Dave
0
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
ID: 37859340
Thanks for your patience on this.  I'm trying to replicate the issue and have as yet to be successful creating this discontinuity.  I tried this archiving a complex test folder in one PST to an archive folder in a different PST and it worked, correctly...

Are you trying to move to/from your Inbox, or between PST folders?  Let me know as there are some curious things going on with this particular area.  Otherwise, what we have at this point should be working properly.  I need to do more research when dealing with the Inbox due to server synchronization, the results are not what I would have expected.

I added a MSGBOX prompt to tell you the source and destination full path as it archives each folder to its archive destination folder.  You should see the same path for each.

As the item is being moved to the specified destination folder, if its displaying the correct full path in FROM and TO folders, then it must move the item accordingly.  

However, to test on your end, please create two PST's with test folders and archive from one to the other new PST files.  If that archives correctly, then the odds grow that we are dealing with a corruption issue in one of your existing PSTs.  I hope not, but that's my only conclusion at this point.

Here's the modified code that prompts for every folder with full path as its moving the items - check to ensure it makes sense as it processes, and of course,  that the items are moved correctly in your test case.

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'Use object to include all subFolder items
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        MsgBox "Moving: " & vbCrLf & subFolder.folderPath & vbCrLf & " to: " & vbCrLf & subDestFolder.folderPath
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = mItem.ReceivedTime
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window


Dave
0
 

Author Comment

by:HelpdeskJBC
ID: 37859442
Thanks

I used the version before and changed Line 63 - 65 to an yes/no messagebox, because the folder function has problems with foldernames than includes this slash "/"

in the destination it is replaced with %2F
so the source and destination foldername is different ;-)

but its not a big deal, I've already managed to seperate 4 gig of old Mails and until now everything is fine.
0
 

Author Closing Comment

by:HelpdeskJBC
ID: 37859446
Thanks for the Help
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37859592
WOW - that's some great work.  Note, my comment on issues moving to/from inbox was invalid as I had a creation time problem with my test data and nothing was being moved because of the time of creation, which should not happen in "real life", though you could modify line 69 (below) to:

chkTime = DateValue(Format(mItem.ReceivedTime,"MM/DD/YYYY"))

Open in new window


Then we are comparing dates to dates, leaving the time of creation out of the equation!

So we have a special character problem with folder names?  I made changes to the code to deal with the slash (see line 145), and more replace commands would be needed for other special characters (need to find a list from some resource to be 100% complete):
Option Explicit
Const strSpecialChars = "[,],/,\,&,~,?,*,|,<,>,"",;,:,+" 'find codes for all special characters, and replace accordingly for proper folder creation
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'Use object to include all subFolder items
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        'MsgBox "Moving: " & vbCrLf & subFolder.folderPath & vbCrLf & " to: " & vbCrLf & subDestFolder.folderPath
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = DateValue(Format(mItem.ReceivedTime, "MM/DD/YYYY"))
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
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 GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            'deal with special characters
            newFolder = Replace(Replace(Replace(chkFolder, "%2f", "/"), "%2F", "/"), "\\", "") 'chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            'now, create the folder
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window


Cheers,

Dave
0

Featured Post

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
If you don't know how to downgrade, my instructions below should be helpful.
Viewers will learn the different options available in the Backstage view in Excel 2013.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now