New to Outlook 2013, dealing with copying vs. moving sent items

outlook2013

Member
Outlook version
Outlook 2013 64 bit
Email Account
Exchange Server
New to Outlook 2013, first VBA code works, second one does not, can someone shed some light on this?

I am dealing with Moving Sent Items from Online Mailbox to PST\Sent Items:

Rule setup to “COPY” sent emails to BaseMailbox.pst\Sent Items

Inserted VBA code here to mark it as READ. This works fine but now I have the Sent Item in both Sent Items folders.

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Set Items = GetFolderPath("BaseMailbox\Sent Items").Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
Item.UnRead = False
Item.Save

End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function


GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function

End Function

So I’d rather move the Sent Item from online mailbox to BaseMailbox.pst\Sent Items instead of Copy, mark unread

So I Disabled Copy Send Items rule and changed the VBA code to this:

I get an error on running it at Item.Move MovePst

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()

Set Items = Session.GetDefaultFolder(olFolderSentMail).Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
Set MovePst = GetFolderPath("BaseMailbox\Sent Items")
Item.UnRead = False
Item.Move MovePst

End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function


GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function

End Function
 
Top