Solved

VBA Question - Where to place a function within the code?

Posted on 2006-06-21
15
303 Views
Last Modified: 2008-01-16

I have a sub procedure which calls a function.  Does the function code have to be within this:

Public Sub ImportOutlookItems()

End Sub

Or can it be outside?

Here is the code as I currently have, however when it runs it crashes access ?

--------------------------------------------------------------------------------------------

Option Compare Database

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String
   
    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function


Public Sub ImportOutlookItems()
    Dim Olapp As Outlook.Application
    Dim Olmapi As Outlook.NameSpace
    Dim Olfolder As Outlook.MAPIFolder
    Dim OlNetwork As Outlook.MAPIFolder
    Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
    Dim OlItems As Outlook.Items
    Dim OlRecips As Outlook.Recipients
    Dim OlRecip As Outlook.Recipient
    Dim Rst As Recordset
    Set Rst = CurrentDb.OpenRecordset("tbl_Temp") 'Open table tbl_temp
'Create a connection to outlook
    Set Olapp = CreateObject("Outlook.Application")
    Set Olmapi = Olapp.GetNamespace("MAPI")
'Open the inbox
    Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
    Set OlItems = Olfolder.Items

'Set up the folders the mails are going to be deposited in
    Set OlNetwork = Olfolder.Folders("Network")
'Set up a loop to run till the inbox is empty (otherwise it skips some)
    Do Until OlItems.Count = 0
'Reset the olitems object otherwise new incoming mails and moving mails get missed
    Set OlItems = Olfolder.Items
    For Each OlMail In OlItems
'For each mail in the collection check the subject line and process accordingly
    If OlMail.UnRead = True Then
        OlMail.UnRead = False 'Mark mail as read
        Rst.AddNew
        Rst!Name = OlMail.SenderName
        If InStr(1, OlMail.Subject, "Network Review") > 0 Then
            Rst!Status = "Attending"
            Rst!datesent = OlMail.ReceivedTime
           Rst!Content = ParseTextLinePair(OlMail.Body)
            OlMail.Move OlNetwork
        End If
        Rst.Update
    End If
    Next
    Loop
    MsgBox "Your wish is my command. New mails have been checked. Please check the tbl_temp for details", vbOKOnly
End Sub

0
Comment
Question by:andyw27
  • 7
  • 5
  • 3
15 Comments
 
LVL 29

Expert Comment

by:leonstryker
Comment Utility
Which line does it crash on?
0
 

Author Comment

by:andyw27
Comment Utility

If I end the outlook.exe task is fails on this line:

Do Until OlItems.Count = 0

It does however add the desired information to the database.
0
 
LVL 29

Expert Comment

by:leonstryker
Comment Utility
What do you mean by "If I end the outlook.exe task "?  Are you manually closing Outlook?
0
 

Author Comment

by:andyw27
Comment Utility

Yes, closing outlook causes Access to unfreeze
0
 
LVL 29

Expert Comment

by:leonstryker
Comment Utility
And does it work correctly (and not crash) if you do not close Outlook?
0
 
LVL 1

Expert Comment

by:beckw
Comment Utility
Hi,

You're putting Outlook into a continuos loop. The do loop will only exit if no more email exist. The code within the do loop only moves the email if if meets the criteria you've set ie. the email must be unread etc. If you've got any read emails in there then the loop will never end
0
 

Author Comment

by:andyw27
Comment Utility

If I don't close outlook, access freezes.

Freezes but still seems to insert the information into the database. so its appears to be going once round.

Maybe its getting stuck in some kind of infinite loop
0
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 
LVL 1

Expert Comment

by:beckw
Comment Utility
Just one more quick point, can't you just comment out the 'Do Until OlItems.Count = 0' and 'Loop' lines. The 'For Each OlMail In OlItems' loop will make sure every email gets checked.
0
 

Author Comment

by:andyw27
Comment Utility

Ah that sound like flaw.

Any suggestions how I can get round this.

Id there away of counting the emails that are in the folder first and then only running the code for that amount of times ?

0
 

Author Comment

by:andyw27
Comment Utility

I've found a piece of code:

MapiFolder.Items.Count

I saved this to a variable.

Any idea how can changed the do loop to a loop that will only repeat this amount of time?
0
 
LVL 1

Expert Comment

by:beckw
Comment Utility
What happens when you comment out the 'Do Until OlItems.Count = 0' and 'Loop' lines. The 'For Each OlMail In OlItems' will only go through each email once.

ie if you have 500 emails in your inbox then the For Each line will go through 500 times. If you've only got 2 emails in your inbox then the For Each line will only go through 2 emals.

Your code with the 2 lines commented out:

Option Compare Database

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String
   
    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function


Public Sub ImportOutlookItems()
    Dim Olapp As Outlook.Application
    Dim Olmapi As Outlook.NameSpace
    Dim Olfolder As Outlook.MAPIFolder
    Dim OlNetwork As Outlook.MAPIFolder
    Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
    Dim OlItems As Outlook.Items
    Dim OlRecips As Outlook.Recipients
    Dim OlRecip As Outlook.Recipient
    Dim Rst As Recordset
    Set Rst = CurrentDb.OpenRecordset("tbl_Temp") 'Open table tbl_temp
'Create a connection to outlook
    Set Olapp = CreateObject("Outlook.Application")
    Set Olmapi = Olapp.GetNamespace("MAPI")
'Open the inbox
    Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
    Set OlItems = Olfolder.Items

'Set up the folders the mails are going to be deposited in
    Set OlNetwork = Olfolder.Folders("Network")
'Set up a loop to run till the inbox is empty (otherwise it skips some)
    'Do Until OlItems.Count = 0
'Reset the olitems object otherwise new incoming mails and moving mails get missed
    Set OlItems = Olfolder.Items
    For Each OlMail In OlItems
'For each mail in the collection check the subject line and process accordingly
    If OlMail.UnRead = True Then
        OlMail.UnRead = False 'Mark mail as read
        Rst.AddNew
        Rst!Name = OlMail.SenderName
        If InStr(1, OlMail.Subject, "Network Review") > 0 Then
            Rst!Status = "Attending"
            Rst!datesent = OlMail.ReceivedTime
           Rst!Content = ParseTextLinePair(OlMail.Body)
            OlMail.Move OlNetwork
        End If
        Rst.Update
    End If
    Next
    'Loop
    MsgBox "Your wish is my command. New mails have been checked. Please check the tbl_temp for details", vbOKOnly
End Sub
0
 

Author Comment

by:andyw27
Comment Utility

That kind of work although it only takes the first two emails, anymore and you have to run it again.
0
 
LVL 1

Accepted Solution

by:
beckw earned 500 total points
Comment Utility
The quick fix would be to add DoEvents just under you Do Loop as follows:

Option Compare Database

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String
   
    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function


Public Sub ImportOutlookItems()
    Dim Olapp As Outlook.Application
    Dim Olmapi As Outlook.NameSpace
    Dim Olfolder As Outlook.MAPIFolder
    Dim OlNetwork As Outlook.MAPIFolder
    Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
    Dim OlItems As Outlook.Items
    Dim OlRecips As Outlook.Recipients
    Dim OlRecip As Outlook.Recipient
    Dim Rst As Recordset
    Set Rst = CurrentDb.OpenRecordset("tbl_Temp") 'Open table tbl_temp
'Create a connection to outlook
    Set Olapp = CreateObject("Outlook.Application")
    Set Olmapi = Olapp.GetNamespace("MAPI")
'Open the inbox
    Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
    Set OlItems = Olfolder.Items

'Set up the folders the mails are going to be deposited in
    Set OlNetwork = Olfolder.Folders("Network")
'Set up a loop to run till the inbox is empty (otherwise it skips some)
    Do Until OlItems.Count = 0
        DoEvents
'Reset the olitems object otherwise new incoming mails and moving mails get missed
    Set OlItems = Olfolder.Items
    For Each OlMail In OlItems
'For each mail in the collection check the subject line and process accordingly
    If OlMail.UnRead = True Then
        OlMail.UnRead = False 'Mark mail as read
        Rst.AddNew
        Rst!Name = OlMail.SenderName
        If InStr(1, OlMail.Subject, "Network Review") > 0 Then
            Rst!Status = "Attending"
            Rst!datesent = OlMail.ReceivedTime
           Rst!Content = ParseTextLinePair(OlMail.Body)
            OlMail.Move OlNetwork
        End If
        Rst.Update
    End If
    Next
    Loop
    MsgBox "Your wish is my command. New mails have been checked. Please check the tbl_temp for details", vbOKOnly
End Sub

All 'DoEvents' does is lets other programs have the focus. (Adding the sleep API call in will also stop the processor from running high)

The best solution if you have Outlook 2000 or above (might be worth opening another question as i can't help tonight) is to modify the code and have it in Outlooks 'Application_NewMail' event. This will then run whenever you get a new email.











.




 This is likely to only way you'll be able to get it to work constantly is to pause the code by using the sleep API

First, you need to place a declaration in a public
module:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Then wherever I need the pause all I have to do is type a simple line of
code with the variable in milliseconds.  For example, to pause the operation
of a sub for 5 seconds, I would put the following:


Sleep (5000)

0
 
LVL 1

Expert Comment

by:beckw
Comment Utility
Sorry, forgot to delete the bottom of the last reply. Just forget everything below the
This is likely to only way you'll be able to get it to work ..................... line.
0
 

Author Comment

by:andyw27
Comment Utility

Thanks that has worked.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now