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


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

andyw27Asked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
beckwConnect With a Mentor Commented:
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
 
leonstrykerCommented:
Which line does it crash on?
0
 
andyw27Author Commented:

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
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
leonstrykerCommented:
What do you mean by "If I end the outlook.exe task "?  Are you manually closing Outlook?
0
 
andyw27Author Commented:

Yes, closing outlook causes Access to unfreeze
0
 
leonstrykerCommented:
And does it work correctly (and not crash) if you do not close Outlook?
0
 
beckwCommented:
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
 
andyw27Author Commented:

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
 
beckwCommented:
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
 
andyw27Author Commented:

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
 
andyw27Author Commented:

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
 
beckwCommented:
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
 
andyw27Author Commented:

That kind of work although it only takes the first two emails, anymore and you have to run it again.
0
 
beckwCommented:
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
 
andyw27Author Commented:

Thanks that has worked.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.