![]() |
If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Search this Thread | Display Modes |
|
#2
|
|||
|
|||
![]()
Okay so using the ItemAdd example from the link provided by Ken, and another
bit of example code from Sue Mosher for parsing data pairs (very useful! see 'Function ParseTextLinePair' in 'code so far..' below), I have got quite far.. The macro triggers upon receipt of an email in a particular folder, checks for 'Draft' or 'Final' version and if 'Final' matches the email to the 'draft' version then moves both. So next bit I am currently stuck on is how to reply to an email after x minutes (Lets say 20 mins) if the 'final' version has not turned up to be matched off. It seems that 'OnTime' is an excel only VBA function, does Outlook have an equivalent? or is there another way I can do this? Thank you in advance Quote from original request:- "3. If after x minutes from “draft” email being sent the “final” has not turned up can you set it so the system will send out an email to the email in “email” saying To [FROM]. You have sent an email [CONTENT] but this is [VERSION]. Please send a revised version 4. Draft email and the new sent one then get moved to a UNMATCHED inbox." Code So Far... Option Explicit Private WithEvents olRecboxItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") ' instantiate objects declared WithEvents Set olRecboxItems = objNS.Folders("Mailbox - One, Some").Folders _ ("Inbox").Folders("reconciliation").Items Set objNS = Nothing End Sub Private Sub olRecboxItems_ItemAdd(ByVal Item As Object) 'Dim VerType As Integer Dim NVersionType As String Dim NWhoFrom As String Dim NDateSent As String Dim ExistItem As Variant Dim ExVersionType As String Dim ExWhoFrom As String Dim ExDateSent As String Dim MesgText As String Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") Set DesFldr = objNS.Folders("Mailbox - One, Some").Folders("Inbox") _ .Folders("reconciliation").Folders("Matched") Set objNS = Nothing 'On Error Resume Next 'VerType = Item.Body Like "*Draft*" 'works with Case True/False NVersionType = ParseTextLinePair(Item.Body, "Version:") NWhoFrom = ParseTextLinePair(Item.Body, "From:") ‘NDateSent = ParseTextLinePair(Item.Body, "Date:") Select Case NVersionType Case Is = "Draft" MsgBox NVersionType & " Test message(draft)" Case Is = "Final" MsgBox NVersionType & " Version - Sent by " & NWhoFrom & " on " _ & NDateSent If olRecboxItems.Count 1 Then For Each ExistItem In olRecboxItems 'MsgBox ExistItem.Body ExVersionType = ParseTextLinePair(ExistItem.Body, "Version:") ExWhoFrom = ParseTextLinePair(ExistItem.Body, "From:") 'ExDateSent = ParseTextLinePair(ExistItem.Body, "Date:") If ExVersionType = "Draft" And ExWhoFrom = NWhoFrom Then MsgBox ExistItem.Body & vbCr & vbCr & MesgText & vbCr & _ vbCr & "Matched & Moved" ExistItem.Move DesFldr Item.Move DesFldr Set Item = Nothing Exit Sub End If Next Else MsgBox "No messages to compare Error" Set Item = Nothing Exit Sub End If MsgBox "No Matches" Case Else MsgBox "Unknown Version Error" End Select Set Item = Nothing End Sub 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 strText = Mid(strSource, intLocLabel + intLenLabel) End If End If ParseTextLinePair = Trim(strText) End Functio ----------------------------------------------------------------------------------------------------- "Damon" wrote: Ken, Earlier I type what turned out to be quite a long reply to this but I got blue screened and lost it all. In short, thank you for the link to the ItemAdd example and the HTML code for a new line. I have now got a simple macro to run on receipt of a new email which is a great starting point and I can now add some aesthetic formating to emails composed with VBA. Thank you again "Ken Slovak - [MVP - Outlook]" wrote: You can handle the ItemAdd event on the Items collection of the Inbox to handle new mails coming in. See http://www.outlookcode.com/d/code/zaphtml.htm#cw for an example of an ItemAdd handler. Whatever you end up doing is going to be a string parsing exercise. You can get the item.Body to get the text, from there you have to parse it yourself. For HTML emails you can use HTMLBody. For HTML emails a newline (0x0D 0x0A) won't work. You need to use HTML tags and for a newline that would be "br". Note that reading Body or HTMLBody is restricted for security reasons, you can write them without any restrictions but reading them could be a way of harvesting email addresses so it's restricted. In Outlook 2003 if you use a COM addin and derive all your Outlook objects from the Application object passed in OnConnection you're OK. Deploying macros (Outlook VBA code) is not a recommended best practice, see http://www.outlookcode.com/d/distributevba.htm. For more information about the Outlook security see http://www.outlookcode.com/d/sec.htm. -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message ... I am getting quite good at VBA for Excel but have never written VBA code for Outlook, yet we have been asked the following.. Quote: Not sure who is the macro guru in your team for outlook but could you get them to try to do the following: If an emails comes in with following text (this will not be in from, sent, to, subject boxes but in main message [body] ): First email: Code: RECS From: US11283 Version: Draft Email: Date: 03/02/2007 08:38 Content: Please find attached draft file for the rec Second email: Code: RECS From: US11283 Version: Final Email: Date: 03/02/2007 16:54 Content: Please find attached final file for the rec Can you set up a macro that: 1. moves all emails with code “RECS” to a new inbox called RECONCILIATION 2. checks all emails in RECONCILIATION BOX against each other. If any have same “From:” e.g. LV11283 and the later date one has the Version “Final” then move these emails to a different inbox called MATCHED 3. If after x minutes from “draft” email being sent the “final” has not turned up can you set it so the system will send out an email to the email in “email” saying To [FROM]. You have sent an email [CONTENT] but this is [VERSION]. Please send a revised version 4. Draft email and the new sent one then get moved to a UNMATCHED inbox. :End quote I know that point 1. can be covered by a 'rule' but as for the rest of it I’m not getting far.. I have previously written an EXCEL project that looks at all of the emails in a particular folder, lists particular details of the ones matching certain criteria and then makes pivot tables and stuff. Since receiving the request above I have adapted this and been able to move emails from one folder to another. I could possibly - using 'find', text manipulation and a lot of time to research/experiment - pull out the various bits of information I need to compare. I have also sent emails from outlook using Excel VBA (although I cannot get any form or combination of 'Chr(13)', 'Chr(10)', 'vbNewLine', 'vbCr', 'vbLf' or 'vbCrLf' to make any difference between strings of text in the Body of the text..??? (OL & XL 2000)). However it would obviously be better to have the macro in Outlook being triggered by new mail being received in the appropriate folder rather than a macro that needs to be triggered manually from Excel. Any help would be appreciated! Thank you in advance Damon |
#3
|
|||
|
|||
![]()
Neither Outlook nor VBA directly support a timer object. You can use a call
to a set of Win32 API's to set up a timer that way, you can add a 3rd party timer control to a VBA UserForm or add the VB 6 timer control to a UserForm if you have VB6 installed. You can also run code that checks the system time and does something xx minutes after a certain time by storing the base time in a user property in the item and checking that. -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message news ![]() Okay so using the ItemAdd example from the link provided by Ken, and another bit of example code from Sue Mosher for parsing data pairs (very useful! see 'Function ParseTextLinePair' in 'code so far..' below), I have got quite far.. The macro triggers upon receipt of an email in a particular folder, checks for 'Draft' or 'Final' version and if 'Final' matches the email to the 'draft' version then moves both. So next bit I am currently stuck on is how to reply to an email after x minutes (Lets say 20 mins) if the 'final' version has not turned up to be matched off. It seems that 'OnTime' is an excel only VBA function, does Outlook have an equivalent? or is there another way I can do this? Thank you in advance Quote from original request:- "3. If after x minutes from “draft” email being sent the “final” has not turned up can you set it so the system will send out an email to the email in “email” saying To [FROM]. You have sent an email [CONTENT] but this is [VERSION]. Please send a revised version 4. Draft email and the new sent one then get moved to a UNMATCHED inbox." Code So Far... Option Explicit Private WithEvents olRecboxItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") ' instantiate objects declared WithEvents Set olRecboxItems = objNS.Folders("Mailbox - One, Some").Folders _ ("Inbox").Folders("reconciliation").Items Set objNS = Nothing End Sub Private Sub olRecboxItems_ItemAdd(ByVal Item As Object) 'Dim VerType As Integer Dim NVersionType As String Dim NWhoFrom As String Dim NDateSent As String Dim ExistItem As Variant Dim ExVersionType As String Dim ExWhoFrom As String Dim ExDateSent As String Dim MesgText As String Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") Set DesFldr = objNS.Folders("Mailbox - One, Some").Folders("Inbox") _ .Folders("reconciliation").Folders("Matched") Set objNS = Nothing 'On Error Resume Next 'VerType = Item.Body Like "*Draft*" 'works with Case True/False NVersionType = ParseTextLinePair(Item.Body, "Version:") NWhoFrom = ParseTextLinePair(Item.Body, "From:") ‘NDateSent = ParseTextLinePair(Item.Body, "Date:") Select Case NVersionType Case Is = "Draft" MsgBox NVersionType & " Test message(draft)" Case Is = "Final" MsgBox NVersionType & " Version - Sent by " & NWhoFrom & " on " _ & NDateSent If olRecboxItems.Count 1 Then For Each ExistItem In olRecboxItems 'MsgBox ExistItem.Body ExVersionType = ParseTextLinePair(ExistItem.Body, "Version:") ExWhoFrom = ParseTextLinePair(ExistItem.Body, "From:") 'ExDateSent = ParseTextLinePair(ExistItem.Body, "Date:") If ExVersionType = "Draft" And ExWhoFrom = NWhoFrom Then MsgBox ExistItem.Body & vbCr & vbCr & MesgText & vbCr & _ vbCr & "Matched & Moved" ExistItem.Move DesFldr Item.Move DesFldr Set Item = Nothing Exit Sub End If Next Else MsgBox "No messages to compare Error" Set Item = Nothing Exit Sub End If MsgBox "No Matches" Case Else MsgBox "Unknown Version Error" End Select Set Item = Nothing End Sub 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 strText = Mid(strSource, intLocLabel + intLenLabel) End If End If ParseTextLinePair = Trim(strText) End Functio ----------------------------------------------------------------------------------------------------- |
#4
|
|||
|
|||
![]()
Ken,
Thank you again for the reply.. I do not have VB 6 installed and this project does not otherwise use a userform, I could look into calling Win32 API's - although I haven't done this type of thing before. I have used system information before (usernames, logon names) in VBA so I can probably find how to get the system time and I would be able to use that. I have been experimenting with .DeferredDeliveryTime but have had some flaky results. At first I thought this was just due to the different 'time' on my PC and the mail server, but I also managed to end up with deferred emails that never sent. I also have been seeing suggestions to use task reminders for triggers but have not found an example yet. Damon "Ken Slovak - [MVP - Outlook]" wrote: Neither Outlook nor VBA directly support a timer object. You can use a call to a set of Win32 API's to set up a timer that way, you can add a 3rd party timer control to a VBA UserForm or add the VB 6 timer control to a UserForm if you have VB6 installed. You can also run code that checks the system time and does something xx minutes after a certain time by storing the base time in a user property in the item and checking that. -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message news ![]() Okay so using the ItemAdd example from the link provided by Ken, and another bit of example code from Sue Mosher for parsing data pairs (very useful! see 'Function ParseTextLinePair' in 'code so far..' below), I have got quite far.. The macro triggers upon receipt of an email in a particular folder, checks for 'Draft' or 'Final' version and if 'Final' matches the email to the 'draft' version then moves both. So next bit I am currently stuck on is how to reply to an email after x minutes (Lets say 20 mins) if the 'final' version has not turned up to be matched off. It seems that 'OnTime' is an excel only VBA function, does Outlook have an equivalent? or is there another way I can do this? Thank you in advance Quote from original request:- "3. If after x minutes from “draft” email being sent the “final” has not turned up can you set it so the system will send out an email to the email in “email” saying To [FROM]. You have sent an email [CONTENT] but this is [VERSION]. Please send a revised version 4. Draft email and the new sent one then get moved to a UNMATCHED inbox." Code So Far... Option Explicit Private WithEvents olRecboxItems As Items Private Sub Application_Startup() Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") ' instantiate objects declared WithEvents Set olRecboxItems = objNS.Folders("Mailbox - One, Some").Folders _ ("Inbox").Folders("reconciliation").Items Set objNS = Nothing End Sub Private Sub olRecboxItems_ItemAdd(ByVal Item As Object) 'Dim VerType As Integer Dim NVersionType As String Dim NWhoFrom As String Dim NDateSent As String Dim ExistItem As Variant Dim ExVersionType As String Dim ExWhoFrom As String Dim ExDateSent As String Dim MesgText As String Dim objNS As NameSpace Dim DesFldr As MAPIFolder Set objNS = Application.GetNamespace("MAPI") Set DesFldr = objNS.Folders("Mailbox - One, Some").Folders("Inbox") _ .Folders("reconciliation").Folders("Matched") Set objNS = Nothing 'On Error Resume Next 'VerType = Item.Body Like "*Draft*" 'works with Case True/False NVersionType = ParseTextLinePair(Item.Body, "Version:") NWhoFrom = ParseTextLinePair(Item.Body, "From:") ‘NDateSent = ParseTextLinePair(Item.Body, "Date:") Select Case NVersionType Case Is = "Draft" MsgBox NVersionType & " Test message(draft)" Case Is = "Final" MsgBox NVersionType & " Version - Sent by " & NWhoFrom & " on " _ & NDateSent If olRecboxItems.Count 1 Then For Each ExistItem In olRecboxItems 'MsgBox ExistItem.Body ExVersionType = ParseTextLinePair(ExistItem.Body, "Version:") ExWhoFrom = ParseTextLinePair(ExistItem.Body, "From:") 'ExDateSent = ParseTextLinePair(ExistItem.Body, "Date:") If ExVersionType = "Draft" And ExWhoFrom = NWhoFrom Then MsgBox ExistItem.Body & vbCr & vbCr & MesgText & vbCr & _ vbCr & "Matched & Moved" ExistItem.Move DesFldr Item.Move DesFldr Set Item = Nothing Exit Sub End If Next Else MsgBox "No messages to compare Error" Set Item = Nothing Exit Sub End If MsgBox "No Matches" Case Else MsgBox "Unknown Version Error" End Select Set Item = Nothing End Sub 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 strText = Mid(strSource, intLocLabel + intLenLabel) End If End If ParseTextLinePair = Trim(strText) End Functio ----------------------------------------------------------------------------------------------------- |
#5
|
|||
|
|||
![]()
Well, those are the ways I know of to do a timer sort of thing.
You could I suppose set task reminders but those might not have the granularity you might need. You can only use a granularity of 1 minute. You would the have to catch the reminder firing and cancel the display of the reminder plus dismissing it and then deleting the task so the user won't see it. It might take some experimentation to try to get the reminder canceled without showing it or playing a reminder sound, although that can be disabled when you set the reminder. -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message ... Ken, Thank you again for the reply.. I do not have VB 6 installed and this project does not otherwise use a userform, I could look into calling Win32 API's - although I haven't done this type of thing before. I have used system information before (usernames, logon names) in VBA so I can probably find how to get the system time and I would be able to use that. I have been experimenting with .DeferredDeliveryTime but have had some flaky results. At first I thought this was just due to the different 'time' on my PC and the mail server, but I also managed to end up with deferred emails that never sent. I also have been seeing suggestions to use task reminders for triggers but have not found an example yet. Damon |
#6
|
|||
|
|||
![]()
Ken,
After reading your reply I started looking into the other suggestions you made and I found the following example of using an API timer in VBA (it's from C. Pearsons very helpful site for excel VBA tips.) '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''' Public Declare Function SetTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Function KillTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long) As Long Public TimerID As Long Public TimerSeconds As Single Sub StartTimer() TimerSeconds = 20 ' how often to "pop" the timer. TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc) End Sub Sub EndTimer() On Error Resume Next KillTimer 0&, TimerID End Sub Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _ ByVal nIDEvent As Long, ByVal dwTimer As Long) ' ' The procedure is called by Windows. Put your ' timer-related code here. ' MsgBox "timed event" '------------------ I added this line End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''' This seemed to work great until I decided to test what would happen if the timer was started multiple times. I was pleased to see that the message I had triggering every 20 seconds started triggering multiple times in a 20 seconds period, However it then didn't matter how many times I ran the EndTimer sub the TimerProc sub kept running, even if Outlook was closed (only managed to stop it by deleting TimerProc sub from the module and letting Outlook crash) Would a 3rd party timer in a userform be likely to have a similar issue or not? [Pre Posting Edit--- reading back this text before posting, it has occurred to me that the issue above may be caused because TimerID is the same for each case? If so how could I vary it without varying the TimerSeconds?] So it seems I'm back to task items with reminders for the moment as I can have multiple 'timers' set at once. As the timer is just to send a reminder email it doesn't really need to be at a precise time just approximately 20mins after first email if second is not received yet. Not sure if that is what you meant by 'granularity of 1 minute'... This bit of code... '''''''' Private Sub Application_Reminder(ByVal Item As Object) If Item.Subject = "Auto Recs Reminder" Then '------------------My code here--------------- Item.Delete End If End Sub '''''''' Does prevent the Reminder from showing (although you do notice it try to show) and does, to my mild surprise, delete the TaskItem (I thought it might just delete the reminder attached to the task.) It does beep though so I will have to disable the sound when setting the reminder as you suggest. Again thank you Ken for all your help, before your first reply I did not even have a clue how to get started with Outlook programming (apart from coming here to ask ;-) ) "Ken Slovak - [MVP - Outlook]" wrote: Well, those are the ways I know of to do a timer sort of thing. You could I suppose set task reminders but those might not have the granularity you might need. You can only use a granularity of 1 minute. You would the have to catch the reminder firing and cancel the display of the reminder plus dismissing it and then deleting the task so the user won't see it. It might take some experimentation to try to get the reminder canceled without showing it or playing a reminder sound, although that can be disabled when you set the reminder. -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message ... Ken, Thank you again for the reply.. I do not have VB 6 installed and this project does not otherwise use a userform, I could look into calling Win32 API's - although I haven't done this type of thing before. I have used system information before (usernames, logon names) in VBA so I can probably find how to get the system time and I would be able to use that. I have been experimenting with .DeferredDeliveryTime but have had some flaky results. At first I thought this was just due to the different 'time' on my PC and the mail server, but I also managed to end up with deferred emails that never sent. I also have been seeing suggestions to use task reminders for triggers but have not found an example yet. Damon |
#7
|
|||
|
|||
![]()
I usually use an API timer this way. I haven't done it specifically in VBA
code, it's usually in VB 6 code, but they should be identical or almost identical: First, a CTimer class. Then a basTimer code module, finally code to init and destroy the timer: '************************************************* *********** ' CTimer class '************************************************* *********** Option Explicit '************************************************* *********** ' Slovak Technical Services, Inc. '************************************************* *********** Private iInterval As Long Private ID As Long ' User can attach any Variant data they want to the timer Public Item As Variant Public Event ThatTime() ' SubTimer is independent of VBCore, so it hard codes error handling Public Enum EErrorTimer eeBaseTimer = 13650 ' CTimer eeTooManyTimers ' No more than 10 timers allowed per class eeCantCreateTimer ' Can't create system timer End Enum Friend Sub ErrRaise(e As Long) Dim sText As String Dim sSource As String If e 1000 Then sSource = App.EXEName & ".WindowProc" Select Case e Case eeTooManyTimers sText = "No more than 10 timers allowed per class" Case eeCantCreateTimer sText = "Can't create system timer" End Select Err.Raise e Or vbObjectError, sSource, sText Else ' Raise standard Visual Basic error Err.Raise e, sSource End If End Sub Property Get Interval() As Long Interval = iInterval End Property ' Can't just change interval--you must kill timer and start a new one Property Let Interval(iIntervalA As Long) Dim f As Boolean If iIntervalA 0 Then ' Don't mess with it if interval is the same If iInterval = iIntervalA Then Exit Property ' Must destroy any existing timer to change interval If iInterval Then f = TimerDestroy(Me) Debug.Assert f ' Shouldn't fail End If ' Create new timer with new interval iInterval = iIntervalA If TimerCreate(Me) = False Then ErrRaise eeCantCreateTimer Else If (iInterval 0) Then iInterval = 0 f = TimerDestroy(Me) Debug.Assert f ' Shouldn't fail End If End If End Property ' Must be public so that Timer object can't terminate while client's ThatTime ' event is being processed--Friend wouldn't prevent this disaster Public Sub PulseTimer() RaiseEvent ThatTime End Sub Friend Property Get TimerID() As Long TimerID = ID End Property Friend Property Let TimerID(idA As Long) ID = idA End Property Private Sub Class_Terminate() Interval = 0 End Sub '************************************************* *********** ' End CTimer class '************************************************* *********** '************************************************* *********** ' basTimer code module '************************************************* *********** Option Explicit '************************************************* *********** ' Slovak Technical Services, Inc. '************************************************* *********** ' declares: Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIdEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIdEvent As Long) As Long Private Const cTimerMax = 100 ' Array of timers Public aTimers(1 To cTimerMax) As CTimer ' Added SPM to prevent excessive searching through aTimers array: Private m_cTimerCount As Integer Public Function TimerCreate(timer As CTimer) As Boolean Dim i As Integer On Error Resume Next 'Create the timer timer.TimerID = SetTimer(0&, 0&, timer.Interval, AddressOf TimerProc) If timer.TimerID Then TimerCreate = True For i = 1 To cTimerMax If (aTimers(i) Is Nothing) Then Set aTimers(i) = timer If (i m_cTimerCount) Then m_cTimerCount = i End If TimerCreate = True Exit Function End If Next timer.ErrRaise eeTooManyTimers Else timer.TimerID = 0 timer.Interval = 0 End If Err.Clear End Function Public Function TimerDestroy(timer As CTimer) As Long Dim i As Integer Dim f As Boolean On Error Resume Next ' Find and remove this timer ' SPM - no need to count past the last timer set up in the ' aTimer array: For i = 1 To m_cTimerCount ' Find timer in array If Not (aTimers(i) Is Nothing) Then If timer.TimerID = aTimers(i).TimerID Then f = KillTimer(0, timer.TimerID) ' Remove timer and set reference to nothing Set aTimers(i) = Nothing TimerDestroy = True Exit Function End If End If Next Err.Clear End Function Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal IDEvent As Long, ByVal dwTime As Long) Dim i As Integer On Error Resume Next ' Find the timer with this ID For i = 1 To m_cTimerCount ' SPM: Add a check to ensure aTimers(i) is not nothing! ' This would occur if we had two timers declared from ' the same thread and we terminated the first one before ' the second! Causes serious GPF if we don't do this... If Not (aTimers(i) Is Nothing) Then If IDEvent = aTimers(i).TimerID Then ' Generate the event aTimers(i).PulseTimer Exit Sub End If End If Next Err.Clear End Sub Private Function StoreTimer(timer As CTimer) Dim i As Integer On Error Resume Next For i = 1 To m_cTimerCount If aTimers(i) Is Nothing Then Set aTimers(i) = timer StoreTimer = True Exit Function End If Next Err.Clear End Function '************************************************* *********** ' End basTimer code module '************************************************* *********** '************************************************* *********** ' Code to call and release a timer (in a class module to handle events) '************************************************* *********** Private WithEvents m_oTimer As CTimer '******************* init timer Set m_oTimer = New CTimer m_oTimer.Interval = 500 ' 500 ms (1/2 minute) '******************* timer event handler Private Sub m_oTimer_ThatTime() On Error Resume Next m_oTimer.Interval = 0 ' do something here ' reset timer to restart by m_oTimer.Interval = 500 for every 1/2 minute again End Sub '******************** kill timer If Not (m_oTimer Is Nothing) Then m_oTimer.Interval = 0 Set m_oTimer = Nothing End If -- Ken Slovak [MVP - Outlook] http://www.slovaktech.com Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003 Reminder Manager, Extended Reminders, Attachment Options http://www.slovaktech.com/products.htm "Damon" wrote in message ... Ken, After reading your reply I started looking into the other suggestions you made and I found the following example of using an API timer in VBA (it's from C. Pearsons very helpful site for excel VBA tips.) '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''' Public Declare Function SetTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Function KillTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long) As Long Public TimerID As Long Public TimerSeconds As Single Sub StartTimer() TimerSeconds = 20 ' how often to "pop" the timer. TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc) End Sub Sub EndTimer() On Error Resume Next KillTimer 0&, TimerID End Sub Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _ ByVal nIDEvent As Long, ByVal dwTimer As Long) ' ' The procedure is called by Windows. Put your ' timer-related code here. ' MsgBox "timed event" '------------------ I added this line End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''' This seemed to work great until I decided to test what would happen if the timer was started multiple times. I was pleased to see that the message I had triggering every 20 seconds started triggering multiple times in a 20 seconds period, However it then didn't matter how many times I ran the EndTimer sub the TimerProc sub kept running, even if Outlook was closed (only managed to stop it by deleting TimerProc sub from the module and letting Outlook crash) Would a 3rd party timer in a userform be likely to have a similar issue or not? [Pre Posting Edit--- reading back this text before posting, it has occurred to me that the issue above may be caused because TimerID is the same for each case? If so how could I vary it without varying the TimerSeconds?] So it seems I'm back to task items with reminders for the moment as I can have multiple 'timers' set at once. As the timer is just to send a reminder email it doesn't really need to be at a precise time just approximately 20mins after first email if second is not received yet. Not sure if that is what you meant by 'granularity of 1 minute'... This bit of code... '''''''' Private Sub Application_Reminder(ByVal Item As Object) If Item.Subject = "Auto Recs Reminder" Then '------------------My code here--------------- Item.Delete End If End Sub '''''''' Does prevent the Reminder from showing (although you do notice it try to show) and does, to my mild surprise, delete the TaskItem (I thought it might just delete the reminder attached to the task.) It does beep though so I will have to disable the sound when setting the reminder as you suggest. Again thank you Ken for all your help, before your first reply I did not even have a clue how to get started with Outlook programming (apart from coming here to ask ;-) ) |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Challenge with Oiutlook 2003 Archive | jjjoseph | Outlook - General Queries | 1 | January 15th 07 11:15 PM |
I challenge anyone to answer this one.................Do you dare? | Challenger | Outlook - Installation | 4 | May 3rd 06 06:59 PM |
Here's a challenge - VBA regarding mail | Stealth1 | Outlook and VBA | 3 | April 26th 06 06:03 PM |
A difficult VBA question...a challenge | Stealth1 | Outlook - General Queries | 2 | April 25th 06 10:28 PM |
Spamming Challenge! | [email protected] | Outlook - General Queries | 4 | April 25th 06 03:08 PM |