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

Status
Not open for further replies.
D

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
 
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.
< Outlook Custom Form: Adding Dropdown(Project Code) at the end of subject | Advanced Search in MS Outlook by VBA and SQL >
Similar threads
Thread starter Title Forum Replies Date
U Rolling Back Office broke automatic updates Using Outlook 4
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 Using Outlook 1
Diane Poremsky Exchange Server Updates March 2016 Using Outlook 0
A Latest updates kill BCM 2013 BCM (Business Contact Manager) 0
S Outlook 2013 May 2015 Updates Using Outlook 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
Commodore Outlook 2007 stops fetching Facebook updates Using Outlook 5
Dr. Demento Analogous Outlook code to read info into an array (or collection or whatever) Outlook VBA and Custom Forms 7
M Outlook 365 Amending code so macro runs within current new mail window Outlook VBA and Custom Forms 0
B Requesting VBA code to make Outlook prompt for confirmation when deleting a task? Outlook VBA and Custom Forms 4
N VBA Code Not Working correctly Outlook VBA and Custom Forms 1
P How to get a QR code for automatic signin with Outlook for iOS Using Outlook 5
D Outlook 2021 Using vba code to delete all my spamfolders not only the default one. Outlook VBA and Custom Forms 0
F Color code certain INBOX emails Using Outlook 2
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
J Want to create a button on the nav bar (module add-in) to run code Outlook VBA and Custom Forms 2
H Preventing the 'email address fetch from Exchange' crashing email reading code Exchange Server Administration 0
C Code to move mail with certain attachment name? Does Not work Outlook VBA and Custom Forms 3
Aussie Outlook 365 Rule runs manually but returns the error code "an unexpected error has occurred" when incoming mail arrives Using Outlook 1
S Need code to allow defined starting folder and selection from there to drill down Outlook VBA and Custom Forms 10
D VBA code to select a signature from the signatures list Outlook VBA and Custom Forms 3
S HTML Code Embedded in String Within Open Outlook Email Preventing Replace(Application.ActiveInspector.CurrentItem.HTMLBody From Working Outlook VBA and Custom Forms 4
P Color Code or highlight folders in Outlook 2016 Using Outlook 2
N Please advise code received new mail Using Outlook 0
B Outlook 2016 Unable to view images or logos on the outlook 2016 emails the same html code works well when i use outlook 2010 Using Outlook 0
S Excel vba code to manage outlook web app Using Outlook 10
S Outlook VBA How to adapt this code for using in a different Mail Inbox Outlook VBA and Custom Forms 0
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

Similar threads

Back
Top