I am at a loss as to why this code sometimes fail. The code access another system at work. It is able to do this but my problem seems to be on the lines of code that are . it does not always fail and I'm sure it sometimes moves an email to the same persons folder that it has failed on once before.
I don't think it matters if there is an email in the folder I am trying to move an email to but when it works its great, when it fails it's baffling.
thank you in advance
smiler44
I know the folders I'm trying to move to all look the same but as its work info have made them look the same for posting on forum
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
I get an object cant be found message but trust me, it's there.
I don't think it matters if there is an email in the folder I am trying to move an email to but when it works its great, when it fails it's baffling.
thank you in advance
smiler44
I know the folders I'm trying to move to all look the same but as its work info have made them look the same for posting on forum
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
I get an object cant be found message but trust me, it's there.
Code:
Option Explicit
Dim moveToFolder As Outlook.MAPIFolder
Dim searchItems As Items
Dim msg As MailItem
Dim foundFlag As Boolean
Dim i As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim c As Long
Dim z As Long
Dim unreadmessagesininbox As String
Dim totalmessagesininbox As String
Dim NS As Outlook.Namespace
Dim searchFolder As Outlook.MAPIFolder
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim pos As Integer 'used to help get onea number from subject line
Dim jnum As String ' is the onea number
Dim jcq As String ' is the job controllers queue
Dim counter1
Dim counter2 ' used to help deal with email were there is no jc added 14.01.15
Dim tarrget As String
Sub start()
Load_Extra ' connect to Extra session
If logoncheck = True Then ' checks that you are logged into
Call moveemail
Else
MsgBox "is not logged on..." + Chr(13) + "Please logon to and try again."
Exit Sub
End If
End Sub
Sub moveemail()
' In the Visual Basic Editor (VBE)
' Tools menu | References...
' Tick the entry for
' Microsoft VBScript Regular Expressions 5.5
' &
' microsoft outlook 12.0 object libary
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
counter1 = 0 'used if the subject line does not contain an onea number
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
On Error Resume Next ' To bypass the error when the source folder is not found.
' searchFolder will be Nothing
' Enter the exact names of the folders
' No slashes. Walk the path one folder at a time.
Set searchFolder = NS.Folders("Mailbox - team email").Folders("Inbox")
On Error GoTo 0
If searchFolder Is Nothing Then
MsgBox "Source folder not found!", vbOKOnly + vbExclamation, "searchSubject error"
GoTo ExitRoutine
Else
Debug.Print vbCr & "searchFolder: " & searchFolder
End If
unreadmessagesininbox = searchFolder.UnReadItemCount 'counts the number of unread emails in inbox
'MsgBox ("unread messages = " & unreadMessagesInInbox)
totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
'MsgBox (" total messages = " & TotalmessagesInInbox)
'''''''''''''''''''''''''''''''''''''
'For Each oMail In searchFolder.Items
'If oMail.UnRead Then
'oUnread = oUnread + 1 ' this gets number of unread emails
'Else
'oread = oread + 1 ' this gets number of read emails
'End If
'Next
'MsgBox ("read messages = " & oread)
'''''''''''''''''''''''''''''''''''''''
Set searchItems = searchFolder.Items
For i = searchItems.Count To 1 Step -1
If searchItems(i).Class = olMail Then
Set msg = searchItems(i)
patternabcd123456 msg, foundFlag
If foundFlag = True Then
Debug.Print " Move this mail: " & searchItems(i)
If searchItems(i).UnRead = False Then
searchItems(i).UnRead = True ' if email has been read changes it to unread
End If
Call whattodonow
If counter2 = 1 Then
GoTo nextemail
End If
''''''''''''''''''''''''''''''''
searchItems(i).Move moveToFolder: ScrnChk
End If
End If
nextemail:
Next
ExitRoutine:
totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
MsgBox (totalmessagesininbox & " E-mails remain in the inbox, please check manually")
Set msg = Nothing
Set searchItems = Nothing
Set searchFolder = Nothing
Set NS = Nothing
Call quitexcel
End Sub
Sub patternabcd123456(MyMail As MailItem, fndFlag)
Dim subj As String
Dim re As Object
Dim match As Variant
fndFlag = False
subj = MyMail.Subject
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
pos = InStrRev(subj, "ONEA"): ScrnChk 'can "ONEA" be removed
If pos = "0" Then
pos = InStrRev(subj, "OSAS")
End If
If pos = "0" Then
pos = InStrRev(subj, "BTBA")
End If
If pos = "0" Then
pos = InStrRev(subj, "BTWE")
End If
If pos = "0" Then
pos = InStrRev(subj, "BTSA")
End If
If pos > 0 Then
jnum = Mid(subj, pos, 10): ScrnChk
Else
If pos = 0 Then
counter2 = 1
Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End If
Set re = CreateObject("vbscript.regexp")
re.Pattern = jnum
For Each match In re.Execute(subj)
fndFlag = True
Debug.Print vbCr & subj
Debug.Print " *** Pattern found: " & match
Next
Set re = Nothing
End Sub
Sub whattodonow()
Load_Extra ' connect to Extra session
If logoncheck = True Then ' checks that you are logged into
GoTo chkqueue
Else
MsgBox " is not logged on..." + Chr(13) + "Please logon to and try again."
Exit Sub
End If
''''''''''''''''''''''''''''''''
'makes excel screen smaller
Application.Width = 282
Application.Height = 330
chkqueue:
Application.Width = 282
Application.Height = 330
MyScrn.SendKeys ("<PF12>"): ScrnChk
MyScrn.SendKeys ("<PF12>"): ScrnChk
MyScrn.SendKeys ("<HOME>"): ScrnChk
MyScrn.SendKeys ("JA<Enter>"): ScrnChk ' added 01.01.15
MyScrn.SendKeys ("<TAB>"): ScrnChk
MyScrn.SendKeys (jnum): ScrnChk
MyScrn.SendKeys ("<Enter>"): ScrnChk
'VERSCHK:
c = 13 'across ?
For z = 10 To 21 'down
If Trim(MyScrn.GetString(z, c, 2)) = "" Then GoTo SELVERS
Next
' select version
SELVERS: ScrnChk
'''''''''''''''''''''''''''''''''''''''''''''''''''''
tarrget = "a" ' used to help in next few lines to see what screen macro is on
tarrget = MyScrn.GetString(5, 21, 4): ScrnChk
If tarrget = "ISSU" Then
If z = 11 Then
z = z - 1: ScrnChk
End If
If z = 12 Then
z = z - 2: ScrnChk
End If
End If
If tarrget = " " Then ' targget = nothing
z = z - 1: ScrnChk
End If
If tarrget = "PCAN" Or tarrget = "SUSP" Or tarrget = "ENGC" Then
z = 10
End If
If tarrget = ": IS" Or tarrget = ": SU" Or tarrget = ": CL" Then
jcq = MyScrn.GetString(8, 23, 10): ScrnChk
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
MyScrn.MoveTo z, 5: ScrnChk
MyScrn.SendKeys ("s<HOME>"): ScrnChk
MyScrn.SendKeys ("<enter>"): ScrnChk
tarrget = ""
Do Until tarrget = "Product"
tarrget = MyScrn.GetString(4, 3, 7): ScrnChk
Loop
jcq = MyScrn.GetString(8, 23, 10): ScrnChk
End If
Set moveToFolder = Nothing
counter2 = 0
If jcq = "abcd116B2" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd116B7" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd116C3" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd117B8" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd116B8" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd116C4" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd107B8" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd107B5" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd107B2" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd126C4" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
ElseIf jcq = "abcd116C5" Then
Set moveToFolder = NS.Folders("Mailbox - team email").Folders("Inbox").Folders("team").Folders("name")
Else
counter2 = 1 ' added 14.01.15
End If
End Sub
Sub pause(seconds As Single)
Dim TimeEnd As Long
If seconds > 60 Then
seconds = 60
End If
TimeEnd = Timer + seconds
If TimeEnd > 86390 Then
TimeEnd = 0
End If
Do
DoEvents
Loop Until TimeEnd <= Timer
End Sub