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.
Thread starter Similar threads 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
L calendar delegate updates meeting with resource mailbox involved = double meeting Using Outlook 6
F Order of updates Exchange Server Administration 4
L Exchange Server?, and Platform Updates For OUTLOOK, part of OFFICE 2000 Professional! Using Outlook 1
A Outlook 2010's Meetings with Updates not showing up in scheduling for Outlook 2003 and Outlook 2007 Using Outlook 1
J Shared Tasks: Disable Updates Using Outlook 3
T Outlook calendar - Can not receive calendar updates from other people Using Outlook 1
T Updates on Tasks Assigned to Multiple People Using Outlook 1
S calendar synchronisation between updates made at office and home Using Outlook 1
N File Open Fixs for Outlook 2007 reverted by MS updates... Using Outlook 1
J Problem with Word 2010 and Outlook 2010 after installing today's MS updates Using Outlook 1
F Calender does not get updates, if somebody sends the updated invite. Using Outlook 3
B Microsoft Office Outlook 2007 Error Updates Using Outlook 2
L Updates to meeting does not update in user's calendar Using Outlook 1
L Import contact updates from Excel Using Outlook 1
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
B After Updates last night (9/16/2010) I cannot send email using Outlook 2007 (q.com POP3 account) Using Outlook 1
J Updates to recurring meeting does not update in my calendar (Outlook 2007) Using Outlook 1
J Updates to recurring meeting does not update in my calendar (Outlook 2007) Using Outlook 2
Similar threads


















































Top