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

Status
Not open for further replies.

DAVID POWELL

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
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
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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
egarneau Meeting updates with external contacts (GMail) Using Outlook 1
K Outlook 2010 duplicate download emails 1 inbox 1 PST no updates Using Outlook 3
iwshim Outlook Social Connector for Facebook - updates? work arounds? Using Outlook 1
J Contacts 2016 Web page address content lost after updates Using Outlook 2
Diane Poremsky Outlook 2016 Sept 2016 Updates New Slipstick.com Articles 1
Diane Poremsky Exchange Server Updates March 2016 New Slipstick.com Articles 0
A Latest updates kill BCM 2013 BCM (Business Contact Manager) 0
S Outlook 2013 May 2015 Updates New Slipstick.com Articles 0
C VBA and windows updates Outlook VBA and Custom Forms 1
D Text Of Facebook Status Updates & Posted Photos NOT Showing In Emails Using Outlook 3
I Automatically updates outlook 2011 address book Using Outlook 1
D Forwarding Exchange Email without meeting updates Using Outlook 1
C Rule to Handle Meeting Replies that updates tracking information Using Outlook 2
M Updates to exchange server broke code - please help Using Outlook 2
Commodore Why some RSS feeds stop getting updates? Using Outlook 12
P Managing Calendar Updates Using Outlook 2
S Calendar updates wipe out personal notes. Using Outlook 3
E vCalendar Meeting Requests sending updates instead of sending new invitation Using Outlook 24
S Outllook 2007 stops connecting with Exchange after latest MS Updates Using Outlook 2
D How to manage and configure antispam updates for Hub Transport antispam filter agents at "filesystem Exchange Server Administration 1
M 0x800CCC15: Outlook 2003 Unable to Connect to ISP after 12/14/2010 Updates Using Outlook 2
M My outlook 2007 will not send or receive since last weeks updates. Using Outlook 3
S 6 to 8 second delay in folders opening since installing a number of updates yesterday. Using Outlook 1
M Unable to receive after installing updates Using Outlook 1
O No SSL-IMAP connection Outlook <-> Exchange 2010 after latest client updates? Using Outlook 3
B 0x800CCC18 error after 12/15 Windows 7 Updates Using Outlook 12
B After Latest Security Updates Outlook Will Not Connect to IMAP Server Using Outlook 5
A Outlook after recent updates super slow, SPA login does not work. Using Outlook 14
T Can't receive or send e-mail in Outlook after downloading latest Windows updates on Tuesday, 14 Dec 2010, at 6:00 pm. Using Outlook 3
C Send Meeting Updates Using Outlook 2
Commodore Outlook 2007 stops fetching Facebook updates Using Outlook 5
D How to Get Updates for an Assigned Task in a Shared Tasks Folder? Using Outlook 6
Y Cannot open the Public Folders aftering installing Security Updates 2288953 Using Outlook 5
J Updates to recurring meeting does not update in my calendar (Outlook 2007) Using Outlook 1
B Cannot Start Microsoft Outlook - still after trying all fixes Using Outlook 1
S Add VBA save code Using Outlook 0
C Auto Run VBA Code on new email Outlook VBA and Custom Forms 1
witzker Pls help to change the code for inserting date in Ol contact body Outlook VBA and Custom Forms 5
I Outlook 2003 shows html code when To: field is empty Using Outlook 7
F VBA code to dock Styles whenever I write or edit an email Outlook VBA and Custom Forms 0
S Skype for business meeting vba code Outlook VBA and Custom Forms 1
R Expand VBA Permanent Delete Code Outlook VBA and Custom Forms 6
B Outlook Business Contact Manager with SQL to Excel, User Defined Fields in BCM don't sync in SQL. Can I use VBA code to copy 1 field to another? BCM (Business Contact Manager) 0
A VBA Code in Outlook disappears after first use Outlook VBA and Custom Forms 1
Alex Cotton "invalid or unqualified reference" on code that should work Outlook VBA and Custom Forms 5
F VBA to ensure a code is entered in Subject title Outlook VBA and Custom Forms 1
Z Outlook Custom Form: Adding Dropdown(Project Code) at the end of subject Outlook VBA and Custom Forms 0
N Open & Save VBAProject.Otm using VBA Code Outlook VBA and Custom Forms 1
M error code 0x8DE00006 Using Outlook 1
R VBA Code to permanently delete selected email Outlook VBA and Custom Forms 10

Similar threads

Top