why does this code fail?

smiler44 · Jan 21, 2016

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.

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

Rx_ · Feb 4, 2016

On Error Resume Next
On Error Goto 0

Think I found your problem as to why "when it fails it's baffling" LOL
Think you knew that.
If we created an error trap, a very simple one, it could at least provide the error number and error description in a message box.
The user could take a screen shot of the error.
A better situation would be to create an error trap, log the incident to a local Access table, and recover gracefully.
Once the problem is narrowed down, we have several options on how to address it.

Use the menu bar to assign your code line numbers before you deploy the application to your users. Then, the ERL function identifies exactly where the error occures:

Code:

Sub ErrorTrapUsingLineNumbers()
 
     Dim dblNumer As Double
     Dim dblRnd As Double
 
10   On Error GoTo Hell
     ' A Random Crash for the betting programmer:
20   dblRnd = Rnd()
 
30   Select Case dblRnd
       Case Is < 0.3
40       dblNumber = 3 / 0
50     Case Is < 0.5
60       dblNumber = 5 / 0
70     Case Is < 0.6      
81        dblNumber = 6 / 0 ' line numbers don't have to end in 0
90     Case Is < 0.9
100      dblNumber = 9 / 0
110    Case Else
120      dblNumber = 10 / 0
     End Select
 
130  Exit Sub
' code that finishes is above, bad code goes below
Hell:
140  MsgBox "Value: " & dblRnd & vbCrLf & _
            "Error Line: " & Erl & vbCrLf & _
            "Error: (" & Err.Number & ") " & Err.Description, vbCritical, 
dblNumber 
End Sub

Any of the dblNumber equations will error because of division by zero.
The Rnd function gives a random number between 0 and 1.
The Select Case statement sorts the Rnd to a specific line.
The ERL function identifies which line caused the error and it appears in a Message Box

If the code was numbered (see Debug button, it will automatically number / unnumber code) the error message will inform you or your users exactly what line caused the error.
Now, you may still be baffeled LOL, but at least the line and other informaiton can help answer the question.

smiler44 · Feb 5, 2016

RX_ your right I'm still baffled.
Do I use your code as a separate routine?
How would I get from my sub to your sub?
How do I add row numbers to the code? I did not know that could be done.

I have spent hours trying to work out why my code fails. Searches on the internet etc have drawn a blank. without doubt one of the reasos is I don't understand what a lot of code does, I have just managed to copy or modify stuff and then add bits.

smiler44

Rx_ · Feb 8, 2016

There is a free tool MZTOOLS that is an Add-in to Access. In the code modules, it has a tool bar that will automatically number your line of code.
Of course, you can manually number your lines of code with 10 <tab>
Don't number Dim statements, labels or loops (e.g. For.... Next) just the lines between the loops.

Just like in my example, in your code, add an Exit Sub before the End Sub and add
MsgBox "Value: " & dblRnd & vbCrLf & _
"Error Line: " & Erl & vbCrLf & _
"Error: (" & Err.Number & ") " & Err.Description, vbCritical,
dblNumber

Finally, copy the On Error GoTo Hell
Add a Hell: label after the exit sub.

Do this for all your subs and functions. Just sequentially number the lines of code incremented by 10.
Soon, you can share the line of code that causes your error!

Really suggest using MZTools - it will save a lot of time.
Denver just won the Super Bowl 5 minutes ago - yet, here I am helping you out instead of going downtown to join in the winning Superbowl celebration riots. (Just joking, the riots are just for fun and have nothing to do with winning). LOL

Rx_ · Feb 8, 2016

This is how to do your smallest Sub - you can do this for the rest of your code:

Code:

 Sub pause(seconds As Single)
           Dim TimeEnd As Long
           On Error GoTo Hell        
10            If seconds > 60 Then
20               seconds = 60
            End If
        
30            TimeEnd = Timer + seconds
        
40            If TimeEnd > 86390 Then
50                TimeEnd = 0
            End If
                
            Do
60                DoEvents
            Loop Until TimeEnd <= Timer
Exit Sub     ' followed by label to Error Trap 
Hell:
     ' note as long as the Line Numbers are in order, they don't have to be in any order, skipped to 140
 140  MsgBox "Value of Sub Pause: " & dblRnd & vbCrLf & _
            "Error Line: " & Erl & vbCrLf & _
            "Error: (" & Err.Number & ") " & Err.Description, vbCritical, dblNumber 
  
End Sub

B.T.W. there is some kind of Pause keyword in the windows mobile API.
I don't think this could be confused as it is in VBA.
However - my suggestion would be to change this subroutine to
PauseCode, or PauseThatRefreshes, or PauseInTime...
anything but a single name.

In my younger days, I made a mistake of naming variables First, Second, Third, Forth. I spent half a day debugging something weird. The keyword second is reserved as a unit of time. The compiler didn't understand the context of my code. But, that could be just me.

why does this code fail?

smiler44

Registered User.

Rx_

Nothing In Moderation

smiler44

Registered User.

Rx_

Nothing In Moderation

Rx_

Nothing In Moderation

Similar threads

Users who are viewing this thread