Any updates or fixes that would make this code stop working just moving emails to another folder

DAVID POWELL

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
#1
Excel vba
Outlook 2010 vba

I have the follwoing code coming from Excel with some parameters being used.
Just simply trying to move some emails from one folder in a profile to another folder in another profile.

It stopped working :
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim intCount As Integer
Dim intDateDiff As Long
Dim strDestFolder As String
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
ActiveWindow.Zoom = 80
Sheets("Move").Activate
lastrow = Worksheets("TableTab").Range("A65536").End(xlUp).Row
Startrow = 6
Let Copyrange = "A" & Startrow & ":" & "U" & lastrow
ARlngMovedItems = 0
UDlngMovedItems = 0
x = 5
Do Until Sheets("Move").Range("A" & x).Value = ""
intCount = 0
intDateDiff = 0
ARlngMovedItems = 0
name = ActiveWorkbook.Worksheets("Move").Cells(x, 3).Value
FolderName = Application.WorksheetFunction.VLookup(name, Sheets("TableTab").Range(Copyrange), 2, False)
Role = Application.WorksheetFunction.VLookup(name, Sheets("TableTab").Range(Copyrange), 3, False)


If Role = "TeamMember" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders(Cabinet).Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders(Cabinet).Folders(FolderName)

For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If TypeOf objVariant Is MailItem Then


objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
ElseIf TypeOf objVariant Is ReportItem Then
Call MoveUndelAR
Sheets("Move").Cells(7, 4) = UDlngMovedItems
'intCount = objSourceFolder.Items.Count
End If
Next

Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
ElseIf Role = "Box" And FolderName = "Automatic Replies" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("NonAgents").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("NonAgents").Folders("Automatic Replies")

For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If TypeOf objVariant Is MailItem Then
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
ElseIf TypeOf objVariant Is ReportItem Then
MoveUndelAR
End If
Next


Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1


'' GETTING THE ERROR HERE BECAUSE ITS SAYS A DESTINATION FOLDER DOES NOT EXIST "General Responses" but it is there in a SUBFOLDER under "NonAgents"
'' IN OUTLOOK


ElseIf Role = "Box" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("NonAgents").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("NonAgents").Folders(FolderName)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
End If
Next
Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
''=============================================================================
ElseIf Role = "Aera" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("Aera Energy").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("Aera Energy").Folders(FolderName)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
End If
Next
Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
ElseIf Role = "Hold" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("Hold").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("Hold").Folders(FolderName)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
End If
Next
Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
ElseIf Role = "Transcepta" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("Transcepta").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("Transcepta").Folders(FolderName)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
End If
Next
Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
ElseIf Role = "Unpur" Then
Set objSourceFolder = objNamespace.Folders(Mailboxes).Folders("Unpur Fraud").Folders(FolderName)
Set objDestFolder = objNamespace.Folders(ToMove).Folders("Archive").Folders(Mailboxes).Folders("Unpur Fraud").Folders(FolderName)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
objVariant.Move objDestFolder
ARlngMovedItems = ARlngMovedItems + 1
End If
Next
Sheets("Move").Cells(x, 4) = ARlngMovedItems
x = x + 1
ElseIf Role = "Inbox" Then
Range("C5").Select
x = x + 1
ElseIf Role = "UnDel" Then
Call MoveUndel
x = x + 1
Else
Sheets("Move").Cells(x, 4) = "N/A"
x = x + 1
End If

Loop

' Copy paste from table in Assign sheet into the Distro sheet
Range("MoveTable").Select
Selection.Copy

'Where is the last cell with data?
lastrow = Worksheets("MoveDB").Range("A65536").End(xlUp).Row
Selection.Copy Worksheets("MoveDB").Cells(lastrow + 1, "A")

Range("A5").Select



Thanks
Fordraiders
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#2
Add code to create the folder if it does not exist, so you can see if the names are slightly different.

You'll need to use your object names - but this is how you'd create folder if they didnt exist
Set objNewFolder = objParentFolder.Folders(newFolderName)

If objNewFolder Is Nothing Then
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If
 

Similar threads

Top