?
Solved

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

Posted on 2006-06-21
15
Medium Priority
?
311 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 5
  • 3
15 Comments
 
LVL 29

Expert Comment

by:leonstryker
ID: 16954777
Which line does it crash on?
0
 

Author Comment

by:andyw27
ID: 16954810

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
ID: 16954856
What do you mean by "If I end the outlook.exe task "?  Are you manually closing Outlook?
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 

Author Comment

by:andyw27
ID: 16954880

Yes, closing outlook causes Access to unfreeze
0
 
LVL 29

Expert Comment

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

Expert Comment

by:beckw
ID: 16954924
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
ID: 16954937

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
 
LVL 1

Expert Comment

by:beckw
ID: 16954944
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
ID: 16954966

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
ID: 16954994

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
ID: 16955008
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
ID: 16955112

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 2000 total points
ID: 16955348
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
ID: 16955361
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
ID: 16955518

Thanks that has worked.
0

Featured Post

New feature and membership benefit!

New feature! Upgrade and increase expert visibility of your issues with Priority Questions.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…
Suggested Courses
Course of the Month12 days, 2 hours left to enroll

752 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